DBGrid дважды отрисовывает строку

[Petrakoff Sergey]

Пробую написать программу просмотра dbf-файла, созданного сторонней программой, т.е. не в Lazarus. Естественно возникают проблемы с кодировкой. Взяв за основу статью "Формирование отчета в MSWord с использованием внешней DLL", опубликованной на этом сайте, написал обработчик OnDrawColumnCell для перекодирования "на лету".
С помощью xBaseViewSU создал простейший dbf-файл всего с двумя полями:
ID - тип N,
NAME - тип string.
Добавил две записи:
0 Иванов
1 Петров

Вот код (привожу весь код, так как его надо пробовать, чтобы понять, что я имею ввиду):

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, dbf, db, FileUtil, Forms, Controls, Graphics, Dialogs,
  DBGrids, StdCtrls, LConvEncoding, Menus, Grids;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    CheckBox1: TCheckBox;
    Datasource1: TDatasource;
    Dbf1: TDbf;
    DBGrid1: TDBGrid;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CheckBox1Change(Sender: TObject);
    procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
      DataCol: Integer; Column: TColumn; State: TGridDrawState);
    procedure MenuItem2Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
  PathToMyDir: string;
  Db_Name: string;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.MenuItem2Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    Db_Name:= UTF8ToSys(OpenDialog1.FileName);
    PathToMyDir:= UTF8ToSys(ExtractFilePath(OpenDialog1.FileName));
  end;
  Dbf1.Close;
  Dbf1.FilePath:= PathToMyDir;
  Dbf1.FilePathFull:= PathToMyDir;
  Dbf1.TableName:= Db_Name;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not FileExists(Db_Name) then
  begin
    ShowMessage('Файл БД не выбран');
    exit;
  end;
  Dbf1.Open;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  FieldsOfDB: TField;
  DataOfField: string;
  FieldsAlign: TTextStyle;
begin
  FieldsOfDB:= Column.Field;
  //FieldsAlign.Alignment := taCenter;
  //Column.Title.Alignment:= taCenter;
  DataOfField:= FieldsOfDB.AsString;
  //ShowMessage('');
  DBGrid1.Canvas.FillRect(Rect);
  if CheckBox1.Checked
  then
    DBGRid1.Canvas.TextRect(Rect, 0, 0, CP866ToUTF8(DataOfField), FieldsAlign)
  else
    DBGRid1.Canvas.TextRect(Rect, 0, 0, CP1251ToUTF8(DataOfField), FieldsAlign)
end;

procedure TForm1.CheckBox1Change(Sender: TObject);
begin
  DBGrid1.Refresh;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Dbf1.Close;
  Dbf1.Free;
  Close;
end;

end.


Все нормально работает.
Но, как-то раз, решил посмотреть как ведет себя DBGrid, так сказать, в пошаговом режиме. Вставил

Код: Выделить всё

ShowMessage('');

В приведенном выше коде эта строчка закомментирована.
И что я вижу. DBGrid отрисовывает строки дважды (?!), причем наименования полей выводятся только при повторном перекодировании. А если раскомментировать строку

Код: Выделить всё

Column.Title.Alignment:= taCenter;

так еще больше.
Но ведь это явная потеря производительности! Я не проверял, но для большой таблицы это большая роскошь.
В чем может быть дело? Может я что-то не так делаю?

[v-t-l]

http://freepascal.ru/forum/viewtopic.php?f=5&t=7065&p=53635#p53628

[Petrakoff Sergey]

Спасибо! Так работает. Но ведь файл может быть в кодировке СР1251.
Видимо придется добавить еще две процедуры типа:

Код: Выделить всё

procedure TForm1.DbFieldGetTextFromCP1251(Sender: TField; var aText: string;
  DisplayText: Boolean);
begin
  aText:=CP1251ToUTF8(Sender.AsString);
end;

и в

Код: Выделить всё

procedure TForm1.Dbf1AfterOpen(DataSet: TDataSet);

ставить проверку

Код: Выделить всё

if CheckBox1.Checked
и т.д.

В итоге вот что получается:

Код: Выделить всё

procedure TForm1.DbFieldGetTextFromCP866(Sender: TField; var aText: string;
  DisplayText: boolean);
begin
  aText:=CP866ToUTF8(Sender.AsString);
end;

procedure TForm1.DbFieldSetTextToCP866(Sender: TField; const aText: string);
begin
  Sender.AsString:=UTF8ToCP866(aText);
end;

procedure TForm1.DbFieldGetTextFromCP1251(Sender: TField; var aText: string;
  DisplayText: boolean);
begin
  aText:=CP1251ToUTF8(Sender.AsString);
end;

procedure TForm1.DbFieldSetTextToCP1251(Sender: TField; const aText: string);
begin
  Sender.AsString:=UTF8ToCP1251(aText);
end;

procedure TForm1.Dbf1AfterOpen(DataSet: TDataSet);
var i: integer;
begin
  for i:= 0 to DataSet.FieldCount - 1 do
  begin
    if DataSet.Fields[i].DataType in [ftString, ftMemo, ftFixedChar] then
    begin
      if CheckBox1.Checked then
      begin
        DataSet.Fields[i].OnGetText:=@DbFieldGetTextFromCP866;
        DataSet.Fields[i].OnSetText:=@DbFieldSetTextToCP866;
      end
      else
      begin
        DataSet.Fields[i].OnGetText:=@DbFieldGetTextFromCP1251;
        DataSet.Fields[i].OnSetText:=@DbFieldSetTextToCP1251;
      end;
    end;
  end;
end;

procedure TForm1.CheckBox1Change(Sender: TObject);
begin
  Dbf1.Close;
  Dbf1.Open;
  //Dbf1.AfterOpen:= @Dbf1AfterOpen;
end;


Единственная закавыка, после нажатия на CheckBox1 в обработчике CheckBox1Change

Код: Выделить всё

Dbf1.Refresh;

не вызывает изменений в DBGrid1. Приходится писать неуклюжий код

Код: Выделить всё

Dbf1.Close;
Dbf1.Open;


Может есть другой выход?

[v-t-l]

Код: Выделить всё

uses ..., LConvEncoding;
  TForm1 = class(TForm)
  ...
  private
    { private declarations }
    fToUTF8: TConvertEncodingFunction;
    fFromUTF8: TConvertEncodingFunction;
    procedure DbFieldGetText(Sender: TField; var aText: string; DisplayText: boolean);
    procedure DbFieldSetText(Sender: TField; const aText: string);
  ...
  public
    { public declarations }
  end;
...
procedure TForm1.CheckBox1Change(Sender: TObject);
begin
  if CheckBox1.Checked then
  begin
    fToUTF8:=@CP866ToUTF8;
    fFromUTF8:=@UTF8ToCP866;
  end
  else
  begin
    fToUTF8:=@CP1251ToUTF8;
    fFromUTF8:=@UTF8ToCP1251;
  end;
  if Dbf1.Active then Dbf1.Refresh;
end;

procedure TForm1.DbFieldGetText(Sender: TField; var aText: string;
  DisplayText: boolean);
begin
  aText:=fToUTF8(Sender.AsString);
end;

procedure TForm1.DbFieldSetText(Sender: TField; const aText: string);
begin
  Sender.AsString:=fFromUTF8(aText);
end;