ホーム >プログラム >Delphi 6 ローテクTips

Unicode対応のTListBox

TListBoxをUnicode対応に。

TMyWStringsというUnicodeを保持できるリストを使います。
このリストにUnicodeを持たせ、あとはDrawItemを書き換えてUnicodeを表示させます。

TMyCustomListBox

通常のリストボックスと仮想リストボックスを利用したものを作るのでまずはそれらの土台となるTMyCustomListBoxを作ります。

type
{TMyCustomListBox}
  TLBGetWideDataEvent = procedure(Control: TWinControl; Index: Integer; var Data: WideString) of object;

  TMyCustomListBox = class(TCustomListBox)
  private
    F_slList: TMyWStrings;
    FOnData: TLBGetWideDataEvent;
  protected
    function DoGetData(const Index: Integer): WideString;
    function GetStyle: TListBoxStyle;
    property Items: TMyWStrings read F_slList;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Clear; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  published
    property AutoComplete;
    property Align;
    property Anchors;
    property BevelEdges;
    property BevelInner;
    property BevelKind default bkNone;
    property BevelOuter;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Columns;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property ImeMode;
    property ImeName;
    property IntegralHeight;
    property ItemHeight;
    property MultiSelect;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ScrollWidth;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDataFind;
    property OnDataObject;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;

    property OnData: TLBGetWideDataEvent read FOnData write FOnData;
  end;

TCustomListBoxを継承します。
DoGetDataとDrawItemを実装してOnDataプロパティを書き換えてUnicodeの表示に対応します。
GetStyleはこのクラスを継承する後のクラスで必要になります。

constructor TMyCustomListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  F_slList := TMyWStrings.Create(inherited Items);
end;

destructor TMyCustomListBox.Destroy;
begin
  F_slList.Free;
  inherited Destroy;
end;

procedure TMyCustomListBox.Clear;
begin
  F_slList.Clear;
end;

function TMyCustomListBox.DoGetData(const Index: Integer): WideString;
begin
  if (Assigned(OnData)) then begin
    OnData(Self, Index, Result);
  end else begin
    Result := Items[Index];
  end;
end;

//DrawItem
procedure TMyCustomListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
const
  lci_MARGIN = 2;
var
  lrc_Rect: TRect;
  ls_WData: WideString;
begin
  if (Style in [lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtualOwnerDraw]) and (Assigned(OnDrawItem)) then begin
    OnDrawItem(Self, Index, Rect, State);
  end else begin
    with Canvas do begin
      FillRect(Rect);
      lrc_Rect := Rect;
      if (UseRightToLeftAlignment) then begin
        Dec(lrc_Rect.Right, lci_MARGIN);
      end else begin
        Inc(lrc_Rect.Left,  lci_MARGIN);
      end;
      if (Style in [lbVirtual, lbVirtualOwnerDraw]) then begin
        if (Assigned(FOnData)) then begin
          ls_WData := DoGetData(Index);
        end else if (Index >= 0) and (Index < F_slList.Count) then begin
          ls_WData := Items[Index];
        end else begin
          ls_WData := '';
        end;
      end else begin
        ls_WData := Items[Index];
      end;
      DrawTextW(Handle, PWideChar(ls_WData), -1, lrc_Rect, DT_VCENTER or DT_NOPREFIX or DT_SINGLELINE);
    end;
  end;
end;

function TMyCustomListBox.GetStyle: TListBoxStyle;
begin
  Result := inherited Style;
end;

F_slListをTCustomListBoxのItemsを引数にしてCreateしているのでリストの保存先はTCustomListBox（に実装されているリスト）になります。実際に保存されるのはF_slListによってWideStringからStringに変換されたデータです。そのStringのデータをF_slListを通して取り出すことでWideStringに戻すわけです。
そしてそのWideStringのデータをDrawItemメソッドをオーバーライドすることでDrawTextW APIを使ってUnicodeに対応した描画を行います。

TMyListBox

通常のリストボックス。
メソッドを一つ加えてプロパティ二つをpublishedにするだけです。

{TMyListBox}
  TMyListBox = class(TMyCustomListBox)
  protected
    procedure SetStyle(lbStyle: TListBoxStyle);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Style read GetStyle write SetStyle default lbOwnerDrawFixed;
    property Items;
  end;
constructor TMyListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Style := lbOwnerDrawFixed;
end;
procedure TMyListBox.SetStyle(lbStyle: TListBoxStyle);
begin
  if (lbStyle = lbStandard) then begin
    lbStyle := lbOwnerDrawFixed;
  end;
  inherited Style := lbStyle;
end;

StyleプロパティをセットするためのSetStyleメソッドを加えます。
StyleがlbStandardの場合DrawItemが呼ばれないのでlbStandardを指定した場合はlbOwnerDrawFixedに変換してセットします。

TMｙListBoxEx

次に仮想リストボックスを利用したものを作ります。
通常のリストボックスだと数千行以上のデータを読み込もうとするとえらく時間がかかるようになります。
そういう場合は仮想リストボックスにしてデータはTStringListなどに読み込むようにすると劇的に速くなります。
ただ仮想リストボックスはリストに追加したり削除したりするたびにリストボックスのCountプロパティを変更しないといけない煩わしさがあります。
それを専用のリストクラスを作って解決しようというものです。

type
{ TMyListBoxEx }
  TMyListBoxEx = class(TMyCustomListBox)
  private
    FWStringList: TMyWStrings;
  protected
    procedure DeleteString(Index: Integer); override;
    procedure SetStyle(lbStyle: TListBoxStyle);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure AddItem(Item: WideString; AObject: TObject); reintroduce;
    procedure Clear; override;
    procedure DeleteSelected; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure SelectAll; override;

    property Items: TMyWStrings read FWStringList;
  published
    property Style read GetStyle write SetStyle; // default lbVirtualOwnerDraw; 設計時最初にlbVirtualOwnerDrawにならないのでコメントアウト
  end;

TMyListBoxExStrings

仮想リストボックス用の文字列リストのクラスです。
リストのCountプロパティが変動する時に仮想リストボックスのCountプロパティをセットします。

{TMyListBoxExStrings}
constructor TMyListBoxExStrings.Create(AListBox: TCustomListBox);
begin
  inherited Create;
  FListBox       := AListBox;
  FiTopIndex     := 0;
  FbCountThrough := False;
end;

procedure TMyListBoxExStrings.FSetCount;
begin
  FListBox.Count    := AnsiStrings.Count;
  FListBox.TopIndex := FiTopIndex;
end;

function TMyListBoxExStrings.Add(sStr: WideString): Integer;
begin
  FiTopIndex := FListBox.TopIndex;
  Result := inherited Add(sStr);
  FSetCount;
end;

procedure TMyListBoxExStrings.Insert(iIndex: Integer; sStr: WideString);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited Insert(iIndex, sStr);
  FSetCount;
end;

procedure TMyListBoxExStrings.Assign(slList: TStrings);
begin
  Clear;
  inherited Assign(slList);
  FSetCount;
end;
procedure TMyListBoxExStrings.Assign(slList: TMyWStrings);
begin
  Clear;
  inherited Assign(slList);
  FSetCount;
end;

procedure TMyListBoxExStrings.Attach(slList: TStrings);
begin
  inherited;
  FSetCount;
end;

procedure TMyListBoxExStrings.AddStrings(slList: TStrings);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited AddStrings(slList);
  FSetCount;
end;
procedure TMyListBoxExStrings.AddStrings(slList: TMyWStrings);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited AddStrings(slList);
  FSetCount;
end;

procedure TMyListBoxExStrings.InsertStrings(iIndex: Integer; slList: TStrings);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited InsertStrings(iIndex, slList);
  FSetCount;
end;
procedure TMyListBoxExStrings.InsertStrings(iIndex: Integer; slList: TMyWStrings);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited InsertStrings(iIndex, slList);
  FSetCount;
end;

procedure TMyListBoxExStrings.Delete(iIndex: Integer);
begin
  FiTopIndex := FListBox.TopIndex;
  inherited Delete(iIndex);
  TMyListBoxEx(FListBox).DeleteString(iIndex);
end;

procedure TMyListBoxExStrings.Exchange(iIndex1, iIndex2: Integer);
begin
  FiTopIndex := FListBox.TopIndex; //EndUpdate対策
  inherited Exchange(iIndex1, iIndex2);
end;

procedure TMyListBoxExStrings.LoadFromFile(sFile: WideString);
begin
  inherited LoadFromFile(sFile);
  FSetCount;
end;

procedure TMyListBoxExStrings.BeginUpdate;
begin
  FbCountThrough := True;
end;

procedure TMyListBoxExStrings.EndUpdate;
var
  li_ItemIndex : Integer;
begin
  if (FbCountThrough) then
  begin
    li_ItemIndex   := FListBox.ItemIndex;
    FbCountThrough := False;
    FSetCount;
    FListBox.ItemIndex := li_ItemIndex;
  end;
end;

Unicodeを直接リストに持たせるTMyWStringsから派生させます。
TMyWStringsと同じようにAssignやAddStringsなどのリストを引数に取るものはTStrings版とTMyWStrings版の二つ作成する必要があります。

本体

次に仮想リストボックス本体です。
通常のリストボックスより実装しないといけないメソッドが多くなります。

{TMyListBoxEx}
constructor TMyListBoxEx.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FWStringList := TMyListBoxExStrings.Create(Self);
  if (AOwner is TWinControl) then
  begin
    Parent := TWinControl(AOwner);
    Style  := lbVirtualOwnerDraw;
  end;
end;

destructor TMyListBoxEx.Destroy;
begin
  FWStringList.Free;
  inherited Destroy;
end;

procedure TMyListBoxEx.SetStyle(lbStyle: TListBoxStyle);
begin
  inherited Style := lbVirtualOwnerDraw;
end;

procedure TMyListBoxEx.Clear;
begin
  FWStringList.Clear;
  Count := 0;
end;
procedure TMyListBoxEx.AddItem(Item: WideString; AObject: TObject);
begin
  FWStringList.AddObject(Item, AObject);
  Count := FWStringList.Count;
end;

procedure TMyListBoxEx.SelectAll;
begin
  if (MultiSelect) then
  begin
    SendMessage(Handle, LB_SETSEL, 1, -1);
  end else
  begin
    SendMessage(Handle, LB_SETCURSEL, -1, 0);
  end;
end;

procedure TMyListBoxEx.DeleteString(Index: Integer);
begin
  inherited;
end;
procedure TMyListBoxEx.DeleteSelected;
var
  i, li_Count: Integer;
begin
  FWStringList.BeginUpdate;
  try
    if (MultiSelect) then
    begin
      li_Count := 0;
      for i := FWStringList.Count -1 downto 0 do
      begin
        if (Selected[i]) then
        begin
          FWStringList.Delete(i);
          Inc(li_Count);
          if (li_Count = SelCount) then
          begin
      Break;
          end;
        end;
      end;
    end else
    begin
      if (ItemIndex > -1) then
      begin
        FWStringList.Delete(ItemIndex);
      end;
    end;
  finally
    FWStringList.EndUpdate;
  end;
end;

procedure TMyListBoxEx.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
const
  lci_MARGIN = 2;
var
  lrc_Rect: TRect;
  ls_WData: WideString;
begin
  if (TMyListBoxExStrings(FWStringList).FbCountThrough) then
  begin
Exit;
  end;

  if  (Style = lbVirtualOwnerDraw)
  and (Assigned(OnDrawItem))
  then
  begin
    OnDrawItem(Self, Index, Rect, State);
  end else
  begin
    with Canvas do
    begin
      FillRect(Rect);
      lrc_Rect := Rect;
      if (UseRightToLeftAlignment) then
      begin
        Dec(lrc_Rect.Right, lci_MARGIN);
      end else
      begin
        Inc(lrc_Rect.Left,  lci_MARGIN);
      end;
      if (Assigned(OnData)) then
      begin
        ls_WData := DoGetData(Index);
      end else
      if  (0     <= Index)
      and (Index < FWStringList.Count)
      then
      begin
        //リストの範囲内である
        ls_WData := Items[Index];
      end else
      begin
        ls_WData := '';
      end;
      DrawTextW(Handle, PWideChar(ls_WData), -1, lrc_Rect, DT_VCENTER or DT_NOPREFIX or DT_SINGLELINE);
    end;
  end;
end;

※注意点
通常のリストボックスと違いCreateでStyleのデフォルト値をセットをしません。
本当ならlbVirtualOwnerDrawをセットしたいのですが、それをするとコンポーネントとしてインストールした場合にフォームにドロップするとエラーになってしまいます。
lbVirtualにしてもだめでした。
ということでTMyListBoxExをコンポーネントとしてインストールした場合、設計時フォームにドロップした時のStyleはlbStandardのままです。
そのままでコンパイルしてしまうとリストを読み込んだときにエラーになってしまうので最初にStyleをlbVirtualOwnerDrawに変更する必要があります。

myListBox.pas

2008-07-21: