bmplbox.pas

一个能够置放 BMP 图档的加强版 TListBox 及 TComboBox 构件

    property LeftMargin : integer read FLeftMargin write SetLeftMargin default 4;
    property TopAndBottomMargin : integer read FTopAndBottomMargin write SetTopAndBottomMargin default 3;
    property TransparentColor : TColor read FTransparentColor write SetTransparentColor default clGray;
  end;

procedure Register;


implementation


{-TBmpListBox}

constructor TBmpListBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FBitmapStrip := TBitmap.Create;
  FBmpItemWidth := 0;
  yBmpOffset := 0;
  FLeftMargin := 4;
  FTopAndBottomMargin := 3;
  FTransparentColor := clGray;
  Style := lbOwnerDrawVariable;

  {-We should be able to use the lbOwnerDrawFixed style but, strangely
   enough, MeasureItem is never called in that case. Normally, when the
   lbOwnerDrawFixed style is used, the WM_MEASUREITEM message is
   sent once and only once. Since I don't have received the VCL source
   code yet, I cannot explain this behavior but it looks like a bug.}

  bOkToDraw := false;
end;

destructor TBmpListBox.Destroy;
begin
  if Assigned(FBitmapStrip) then
    FBitmapStrip.Destroy;
  inherited Destroy;
end;

procedure TBmpListBox.CheckContext;
begin
 {-Verify that critical properties have been correctly setup}
  bOkToDraw := (FBmpItemWidth > 0) and Assigned(FBitmapStrip) and not FBitmapStrip.Empty;
end;

procedure TBmpListBox.SetBitmapStrip(ABitmapStrip : TBitmap);
begin
 {-Copy data from source bitmap}
  FBitmapStrip.Assign(ABitmapStrip);
  CheckContext;
  Invalidate;
end;

procedure TBmpListBox.SetBmpItemWidth(NewWidth : integer);
begin
  FBmpItemWidth := NewWidth;
  CheckContext;
  Invalidate;
end;

procedure TBmpListBox.SetLeftMargin(NewMargin : integer);
begin
  FLeftMargin := NewMargin;
  Invalidate;
end;

procedure TBmpListBox.SetTransparentColor(NewColor : TColor);
begin
  FTransparentColor := NewColor;
  Invalidate;
end;

procedure TBmpListBox.SetTopAndBottomMargin(NewMargin : integer);
begin
  FTopAndBottomMargin := NewMargin;
  Invalidate;
end;

procedure TBmpListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  OutStr   : PChar;
  len	   : word;
begin
  with Canvas do begin
    FillRect(Rect);
   {-Check critical properties and validity of glyph index}
    if bOkToDraw and ((BmpItemWidth * HiWord(longint(Items.Objects[Index]))) < FBitmapStrip.Width) then
      BrushCopy(Bounds(Rect.left + FLeftMargin,
		       Rect.top + yBmpOffset,
		       FBmpItemWidth,
		       FBitmapStrip.Height),
		FBitmapStrip,
		Bounds(BmpItemWidth * HiWord(longint(Items.Objects[Index])),
		       0,
		       FBmpItemWidth,
		       FBitmapStrip.Height),
		FTransparentColor);
   {-If we're not "OKToDraw", the LeftMargin property is ignored}
   {-We use the DrawText API which is more accurate than Canvas.TextOut}
    Rect.left := Rect.left + BmpItemWidth + (FLeftMargin * 2 * Ord(bOkToDraw));
    len := Length(Items[index]);
    GetMem(OutStr, len + 1);
    StrPCopy(OutStr, Items[index]);
    DrawText(Handle, OutStr, len, Rect, dt_Left or dt_VCenter or dt_SingleLine);
    FreeMem(OutStr, len + 1);
  end;
end;

procedure TBmpListBox.MeasureItem(Index: Integer; var Height: Integer);
var
  TxtHeight : integer;
begin
  if bOkToDraw then begin
    TxtHeight := Abs(Font.Height);
   {- When we receive the WM_MEASUREITEM message, the font used for the
     Control has not been yet determined by Windows. Using Canvas.TextHeight
     would return a wrong value. So, we MUST use the Font property to
     retrieve the font height.}
    if TxtHeight > FBitmapStrip.Height then
      Height := TxtHeight
    else
      Height := FBitmapStrip.Height;
    Inc(Height, FTopAndBottomMargin * 2);
    yBmpOffset := (Height - FBitmapStrip.Height) div 2;
  end;
end;


{-TBmpComboBox - Identical to TBmpListBox}

constructor TBmpComboBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FBitmapStrip := TBitmap.Create;
  FBmpItemWidth := 0;
  yBmpOffset := 0;
  FLeftMargin := 4;
  FTopAndBottomMargin := 3;
  FTransparentColor := clGray;
  Style := csOwnerDrawVariable;
  bOkToDraw := false;
end;

destructor TBmpComboBox.Destroy;
begin
  if Assigned(FBitmapStrip) then
    FBitmapStrip.Destroy;
  inherited Destroy;
end;

procedure TBmpComboBox.CheckContext;
begin
  bOkToDraw := (FBmpItemWidth > 0) and Assigned(FBitmapStrip) and not FBitmapStrip.Empty;
end;

procedure TBmpComboBox.SetBitmapStrip(ABitmapStrip : TBitmap);
begin
  FBitmapStrip.Assign(ABitmapStrip);
  CheckContext;
end;

procedure TBmpComboBox.SetBmpItemWidth(NewWidth : integer);
begin
  FBmpItemWidth := NewWidth;
  CheckContext;
end;

procedure TBmpComboBox.SetLeftMargin(NewMargin : integer);
begin
  FLeftMargin := NewMargin;
  Invalidate;
end;

procedure TBmpComboBox.SetTransparentColor(NewColor : TColor);
begin
  FTransparentColor := NewColor;
  Invalidate;
end;

procedure TBmpComboBox.SetTopAndBottomMargin(NewMargin : integer);
begin
  FTopAndBottomMargin := NewMargin;
  Invalidate;
end;

procedure TBmpComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  OutStr   : PChar;
  len	   : word;
begin
  with Canvas do begin
    FillRect(Rect);
    if bOkToDraw and ((BmpItemWidth * HiWord(longint(Items.Objects[Index]))) < FBitmapStrip.Width) then
      BrushCopy(Bounds(Rect.Left + FLeftMargin,
		       Rect.Top + yBmpOffset,
		       FBmpItemWidth,
		       FBitmapStrip.Height),
		FBitmapStrip,
		Bounds(BmpItemWidth * HiWord(longint(Items.Objects[Index])),
		       0,
		       FBmpItemWidth,
		       FBitmapStrip.Height),
		FTransparentColor);
    Rect.left := Rect.left + BmpItemWidth + (FLeftMargin * 2 * Ord(bOkToDraw));
    len := Length(Items[index]);
    GetMem(OutStr, len + 1);
    StrPCopy(OutStr, Items[index]);
    DrawText(Handle, OutStr, len, Rect, dt_Left or dt_VCenter or dt_SingleLine);
    FreeMem(OutStr, len + 1);
  end;
end;

procedure TBmpComboBox.MeasureItem(Index: Integer; var Height: Integer);
var
  TxtHeight : integer;
begin
  if bOkToDraw then begin
    TxtHeight := Abs(Font.Height);
    if TxtHeight > FBitmapStrip.Height then
      Height := TxtHeight
    else
      Height := FBitmapStrip.Height;
    Inc(Height, FTopAndBottomMargin * 2);
    yBmpOffset := (Height - FBitmapStrip.Height) div 2;
  end;
end;


{-register both components}
procedure Register;
begin
  RegisterComponents('Additional', [TBmpListBox, TBmpComboBox]);
end;

end.