colorcbo.pas

MiniHex 1.1 源程序说明 “MiniHex11SrcSource”目录中的所有文件是MiniHex 1.1的主程序； “MiniHex11SrcControls”目录中的是该软件

{**********************************************************}
{                                                          }
{  TColorCbo Component Version 1.00                        }
{                                                          }
{  Written by DayDream Studio, 1999/9/5                    }
{                                                          }
{  Email: [e-mail]                                    }
{  URL: http://haoxg.yeah.net                              }
{                                                          }
{**********************************************************}

unit ColorCbo;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls,
  Graphics, StdCtrls, Forms, Menus, Dialogs;

type

  TOwnerDrawComboStyle = csDropDown..csDropDownList;
  TColorLanguage = (clEnglish, clChinese);

  TOwnerDrawCbo = class(TCustomComboBox)
  private
    FStyle: TOwnerDrawComboStyle;
    procedure SetComboStyle(Value: TOwnerDrawComboStyle);
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure ResetItemHeight;
    function MinItemHeight: Integer; virtual;
    property Style: TOwnerDrawComboStyle read FStyle write SetComboStyle
      default csDropDownList;
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TColorCbo }

  TColorCbo = class(TOwnerDrawCbo)
  private
    FColorValue: TColor;
    FDisplayNames: Boolean;
    FColorNames: TStrings;
    FSelCustomizeItem: Boolean;
    FLanguage: TColorLanguage;

    FOnChange: TNotifyEvent;
    function GetColorValue: TColor;
    function GetColorCustomizeName: AnsiString;
    procedure SetColorValue(NewValue: TColor);
    procedure SetDisplayNames(Value: Boolean);
    procedure SetColorLanguage(Value: TColorLanguage);
  protected
    procedure CreateWnd; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure Click; override;
    procedure Change; override;
    procedure PopulateList; virtual;
    procedure DoChange; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text;
  published
    property ColorValue: TColor read GetColorValue write SetColorValue default clBlack;
    property Language: TColorLanguage read FLanguage write SetColorLanguage;
    property DisplayNames: Boolean read FDisplayNames write SetDisplayNames default True;
    property Color;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property DropDownCount;
    property Enabled;
    property Font;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property ImeMode;
    property ImeName;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Style;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
    property OnEndDock;
    property OnStartDock;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('DayDream', [TColorCbo]);
end;

function GetItemHeight(Font: TFont): Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  try
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(0, DC);
  end;
  Result := Metrics.tmHeight + 2;
end;

{ TOwnerDrawCbo }

constructor TOwnerDrawCbo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  inherited Style := csDropDownList;
  FStyle := csDropDownList;
end;

procedure TOwnerDrawCbo.SetComboStyle(Value: TOwnerDrawComboStyle);
begin
  if FStyle <> Value then begin
    FStyle := Value;
    inherited Style := Value;
  end;
end;

function TOwnerDrawCbo.MinItemHeight: Integer;

  function Max(A, B: Longint): Longint;
  begin
    if A > B then Result := A
    else Result := B;
  end;
  
begin
  Result := Max(GetItemHeight(Font), 9);
end;

procedure TOwnerDrawCbo.ResetItemHeight;
var
  H: Integer;
begin
  H := MinItemHeight;
  inherited ItemHeight := H;
  if HandleAllocated then SendMessage(Handle, CB_SETITEMHEIGHT, 0, H);
end;

procedure TOwnerDrawCbo.CreateParams(var Params: TCreateParams);
const
  ComboBoxStyles: array[TOwnerDrawComboStyle] of DWORD =
    (CBS_DROPDOWN, CBS_SIMPLE, CBS_DROPDOWNLIST);
begin
  inherited CreateParams(Params);
  with Params do
    Style := (Style and not CBS_DROPDOWNLIST) or CBS_OWNERDRAWFIXED or
      ComboBoxStyles[FStyle];
end;

procedure TOwnerDrawCbo.CreateWnd;
begin
  inherited CreateWnd;
  ResetItemHeight;
end;

procedure TOwnerDrawCbo.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ResetItemHeight;
  RecreateWnd;
end;

{ TColorCbo }

const
  ColorsInList = 16;
  ColorValues: array [0..ColorsInList - 1] of TColor = (
    clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
    clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);

constructor TColorCbo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColorValue := clBlack;  { make default color selected }
  FColorNames := TStringList.Create;
  FDisplayNames := True;
  FSelCustomizeItem := False;
  SetColorLanguage(clChinese);
end;

destructor TColorCbo.Destroy;
begin
  TStringList(FColorNames).OnChange := nil;
  FColorNames.Free;
  FColorNames := nil;
  inherited Destroy;
end;

procedure TColorCbo.CreateWnd;
begin
  inherited CreateWnd;
  PopulateList;
  SetColorValue(FColorValue);
end;

procedure TColorCbo.PopulateList;
var
  I: Integer;
begin
  Items.BeginUpdate;
  try
    Clear;
    for I := 0 to Pred(ColorsInList) do
      Items.AddObject(FColorNames[I], TObject(ColorValues[I]));
    Items.AddObject(GetColorCustomizeName, TObject(ColorValues[0]));
  finally
    Items.EndUpdate;
  end;
end;

procedure TColorCbo.SetColorLanguage(Value: TColorLanguage);
begin
  FLanguage := Value;
  FColorNames.Clear;
  case Value of
    clEnglish:
      begin
        FColorNames.Add('Black');
        FColorNames.Add('Maroon');
        FColorNames.Add('Green');
        FColorNames.Add('Olive');
        FColorNames.Add('Navy');
        FColorNames.Add('Purple');
        FColorNames.Add('Teal');
        FColorNames.Add('Gray');
        FColorNames.Add('Silver');
        FColorNames.Add('Red');
        FColorNames.Add('Lime');
        FColorNames.Add('Yellow');
        FColorNames.Add('Blue');
        FColorNames.Add('Fuchsia');
        FColorNames.Add('Aqua');
        FColorNames.Add('White');
      end;
    clChinese:
      begin
        FColorNames.Add('黑色');
        FColorNames.Add('深红色');
        FColorNames.Add('绿色');
        FColorNames.Add('橄榄色');
        FColorNames.Add('藏青色');
        FColorNames.Add('紫色');
        FColorNames.Add('青色');
        FColorNames.Add('灰色');
        FColorNames.Add('银色');
        FColorNames.Add('红色');
        FColorNames.Add('浅绿色');
        FColorNames.Add('黄色');
        FColorNames.Add('蓝色');
        FColorNames.Add('紫红色');
        FColorNames.Add('浅绿色');
        FColorNames.Add('白色');
      end;
  end;

  if HandleAllocated then begin
    FColorValue := ColorValue;
    RecreateWnd;
  end;
end;

procedure TColorCbo.SetDisplayNames(Value: Boolean);
begin
  if DisplayNames <> Value then begin
    FDisplayNames := Value;
    Invalidate;
  end;
end;

function TColorCbo.GetColorValue: TColor;
var
  I: Integer;
begin
  Result := FColorValue;
  if (Style <> csDropDownList) and (ItemIndex < 0) then begin
    I := Items.IndexOf(inherited Text);
    if I >= 0 then Result := TColor(Items.Objects[I])
    else begin
      Val(inherited Text, Result, I);
      if I <> 0 then Result := FColorValue;
    end;
  end;
end;

function TColorCbo.GetColorCustomizeName: AnsiString;
begin
  if FLanguage = clEnglish then Result := 'Customize'
  else Result := '定制';
end;

procedure TColorCbo.SetColorValue(NewValue: TColor);
var
  Item: Integer;
  CurrentColor: TColor;
begin
  if (ItemIndex < 0) or (NewValue <> FColorValue) then begin
    FColorValue := NewValue;
    { change selected item }
    for Item := 0 to Items.Count do begin
      CurrentColor := TColor(Items.Objects[Item]);
      if FSelCustomizeItem and (CurrentColor = NewValue) then
      begin
        ItemIndex := Items.Count - 1;
        DoChange;
        Exit;
      end
      else if CurrentColor = NewValue then
      begin
        if ItemIndex <> Item then ItemIndex := Item;
        DoChange;
        Exit;
      end;
    end;
    Items.Delete(Items.Count - 1);
    Items.AddObject(GetColorCustomizeName, TObject(NewValue));
    ItemIndex := Items.Count - 1;
    DoChange;
  end;
end;

procedure TColorCbo.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
const
  ColorWidth = 22;
var
  ARect: TRect;
  Text: array[0..255] of Char;
  Safer: TColor;
begin
  ARect := Rect;
  Inc(ARect.Top, 2);
  Inc(ARect.Left, 2);
  Dec(ARect.Bottom, 2);
  if FDisplayNames then ARect.Right := ARect.Left + ColorWidth
  else Dec(ARect.Right, 3);
  with Canvas do begin
    FillRect(Rect);
    Safer := Brush.Color;
    Pen.Color := clWindowText;
    Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
    Brush.Color := TColor(Items.Objects[Index]);
    try
      InflateRect(ARect, -1, -1);
      FillRect(ARect);
    finally
      Brush.Color := Safer;
    end;
    if FDisplayNames then begin
      StrPCopy(Text, Items[Index]);
      Rect.Left := Rect.Left + ColorWidth + 6;
      DrawText(Canvas.Handle, Text, StrLen(Text), Rect,
        DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
        //DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
    end;
  end;
end;

procedure TColorCbo.Change;
var
  AColor: TColor;
begin
  inherited Change;
  AColor := GetColorValue;
  if FColorValue <> AColor then begin
    FColorValue := AColor;
    DoChange;
  end;
end;

procedure TColorCbo.Click;
var
  ColorDlg: TColorDialog;
begin
  if ItemIndex = Items.Count - 1 then FSelCustomizeItem := True
  else FSelCustomizeItem := False;

  if ItemIndex = Items.Count - 1  then
  begin
    ColorDlg := TColorDialog.Create(Application);
    ColorDlg.Options := ColorDlg.Options + [cdFullOpen];
    ColorDlg.Color := TColor(Items.Objects[ItemIndex]);
    if ColorDlg.Execute then
    begin
      Items.Delete(Items.Count - 1);
      Items.AddObject(GetColorCustomizeName, TObject(ColorDlg.Color));
      ItemIndex := Items.Count - 1;
    end;
    ColorDlg.Free;
    ColorValue := TColor(Items.Objects[ItemIndex])
  end
  else if ItemIndex >= 0 then
    ColorValue := TColor(Items.Objects[ItemIndex]);

  inherited Click;
end;

procedure TColorCbo.DoChange;
begin
  if not (csReading in ComponentState) then
    if Assigned(FOnChange) then FOnChange(Self);
end;

end.