home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / RxCombos.pas < prev    next >
Pascal/Delphi Source File  |  1999-10-12  |  22KB  |  835 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995, 1996 AO ROSNO             }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit RxCombos;
  11.  
  12. {.$DEFINE GXE}
  13. { Activate this define to use RxCombos in the GXExplorer Open Source project }
  14.  
  15. {$I RX.INC}
  16. {$W-,T-}
  17.  
  18. interface
  19.  
  20. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  21.   Messages, Classes, Controls, Graphics, StdCtrls, Forms, Menus;
  22.  
  23. type
  24.  
  25. { TOwnerDrawComboBox }
  26.  
  27.   TOwnerDrawComboStyle = csDropDown..csDropDownList;
  28.  
  29.   TOwnerDrawComboBox = class(TCustomComboBox)
  30.   private
  31.     FStyle: TOwnerDrawComboStyle;
  32.     FItemHeightChanging: Boolean;
  33.     procedure SetComboStyle(Value: TOwnerDrawComboStyle);
  34.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  35. {$IFDEF WIN32}
  36.     procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
  37. {$ENDIF}
  38.   protected
  39.     procedure CreateParams(var Params: TCreateParams); override;
  40.     procedure CreateWnd; override;
  41.     procedure ResetItemHeight;
  42.     function MinItemHeight: Integer; virtual;
  43.     property Style: TOwnerDrawComboStyle read FStyle write SetComboStyle
  44.       default csDropDownList;
  45.   public
  46.     constructor Create(AOwner: TComponent); override;
  47.   end;
  48.  
  49. { TColorComboBox }
  50.  
  51.   TColorComboBox = class(TOwnerDrawComboBox)
  52.   private
  53.     FColorValue: TColor;
  54.     FDisplayNames: Boolean;
  55.     FColorNames: TStrings;
  56.     FOnChange: TNotifyEvent;
  57.     function GetColorValue: TColor;
  58.     procedure SetColorValue(NewValue: TColor);
  59.     procedure SetDisplayNames(Value: Boolean);
  60.     procedure SetColorNames(Value: TStrings);
  61.     procedure ColorNamesChanged(Sender: TObject);
  62.   protected
  63.     procedure CreateWnd; override;
  64.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  65.     procedure Click; override;
  66.     procedure Change; override;
  67.     procedure PopulateList; virtual;
  68.     procedure DoChange; dynamic;
  69.   public
  70.     constructor Create(AOwner: TComponent); override;
  71.     destructor Destroy; override;
  72.     property Text;
  73.   published
  74.     property ColorValue: TColor read GetColorValue write SetColorValue
  75.       default clBlack;
  76.     property ColorNames: TStrings read FColorNames write SetColorNames;
  77.     property DisplayNames: Boolean read FDisplayNames write SetDisplayNames
  78.       default True;
  79.     property Color;
  80.     property Ctl3D;
  81.     property DragMode;
  82.     property DragCursor;
  83.     property Enabled;
  84.     property Font;
  85. {$IFDEF RX_D4}
  86.     property Anchors;
  87.     property BiDiMode;
  88.     property Constraints;
  89.     property DragKind;
  90.     property ParentBiDiMode;
  91. {$ENDIF}
  92. {$IFDEF WIN32}
  93.   {$IFNDEF VER90}
  94.     property ImeMode;
  95.     property ImeName;
  96.   {$ENDIF}
  97. {$ENDIF}
  98.     property ParentColor;
  99.     property ParentCtl3D;
  100.     property ParentFont;
  101.     property ParentShowHint;
  102.     property PopupMenu;
  103.     property ShowHint;
  104.     property Style;
  105.     property TabOrder;
  106.     property TabStop;
  107.     property Visible;
  108.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  109.     property OnClick;
  110.     property OnDblClick;
  111.     property OnDragDrop;
  112.     property OnDragOver;
  113.     property OnDropDown;
  114.     property OnEndDrag;
  115.     property OnEnter;
  116.     property OnExit;
  117.     property OnKeyDown;
  118.     property OnKeyPress;
  119.     property OnKeyUp;
  120. {$IFDEF WIN32}
  121.     property OnStartDrag;
  122. {$ENDIF}
  123. {$IFDEF RX_D5}
  124.     property OnContextPopup;
  125. {$ENDIF}
  126. {$IFDEF RX_D4}
  127.     property OnEndDock;
  128.     property OnStartDock;
  129. {$ENDIF}
  130.   end;
  131.  
  132. { TFontComboBox }
  133.  
  134.   TFontDevice = (fdScreen, fdPrinter, fdBoth);
  135.   TFontListOption = (foAnsiOnly, foTrueTypeOnly, foFixedPitchOnly,
  136.     foNoOEMFonts, foOEMFontsOnly, foScalableOnly, foNoSymbolFonts);
  137.   TFontListOptions = set of TFontListOption;
  138.  
  139.   TFontComboBox = class(TOwnerDrawComboBox)
  140.   private
  141.     FTrueTypeBMP: TBitmap;
  142.     FDeviceBMP: TBitmap;
  143.     FOnChange: TNotifyEvent;
  144.     FDevice: TFontDevice;
  145.     FUpdate: Boolean;
  146.     FUseFonts: Boolean;
  147.     FOptions: TFontListOptions;
  148.     procedure SetFontName(const NewFontName: TFontName);
  149.     function GetFontName: TFontName;
  150.     function GetTrueTypeOnly: Boolean;
  151.     procedure SetDevice(Value: TFontDevice);
  152.     procedure SetOptions(Value: TFontListOptions);
  153.     procedure SetTrueTypeOnly(Value: Boolean);
  154.     procedure SetUseFonts(Value: Boolean);
  155.     procedure Reset;
  156.     procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
  157.   protected
  158.     procedure PopulateList; virtual;
  159.     procedure Change; override;
  160.     procedure Click; override;
  161.     procedure DoChange; dynamic;
  162.     procedure CreateWnd; override;
  163.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  164.     function MinItemHeight: Integer; override;
  165.   public
  166.     constructor Create(AOwner: TComponent); override;
  167.     destructor Destroy; override;
  168.     property Text;
  169.   published
  170.     property Device: TFontDevice read FDevice write SetDevice default fdScreen;
  171.     property FontName: TFontName read GetFontName write SetFontName;
  172.     property Options: TFontListOptions read FOptions write SetOptions default [];
  173.     property TrueTypeOnly: Boolean read GetTrueTypeOnly write SetTrueTypeOnly
  174.       stored False; { obsolete, use Options instead }
  175.     property UseFonts: Boolean read FUseFonts write SetUseFonts default False;
  176.     property Color;
  177.     property Ctl3D;
  178.     property DragMode;
  179.     property DragCursor;
  180.     property Enabled;
  181.     property Font;
  182. {$IFDEF RX_D4}
  183.     property Anchors;
  184.     property BiDiMode;
  185.     property Constraints;
  186.     property DragKind;
  187.     property ParentBiDiMode;
  188. {$ENDIF}
  189. {$IFDEF WIN32}
  190.   {$IFNDEF VER90}
  191.     property ImeMode;
  192.     property ImeName;
  193.   {$ENDIF}
  194. {$ENDIF}
  195.     property ParentColor;
  196.     property ParentCtl3D;
  197.     property ParentFont;
  198.     property ParentShowHint;
  199.     property PopupMenu;
  200.     property ShowHint;
  201.     property Style;
  202.     property TabOrder;
  203.     property TabStop;
  204.     property Visible;
  205.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  206.     property OnClick;
  207.     property OnDblClick;
  208.     property OnDragDrop;
  209.     property OnDragOver;
  210.     property OnDropDown;
  211.     property OnEndDrag;
  212.     property OnEnter;
  213.     property OnExit;
  214.     property OnKeyDown;
  215.     property OnKeyPress;
  216.     property OnKeyUp;
  217. {$IFDEF WIN32}
  218.     property OnStartDrag;
  219. {$ENDIF}
  220. {$IFDEF RX_D5}
  221.     property OnContextPopup;
  222. {$ENDIF}
  223. {$IFDEF RX_D4}
  224.     property OnEndDock;
  225.     property OnStartDock;
  226. {$ENDIF}
  227.   end;
  228.  
  229. {$IFDEF GXE}
  230. procedure Register;
  231. {$ENDIF}
  232.  
  233. implementation
  234.  
  235. {$IFDEF WIN32}
  236.  {$R *.R32}
  237. {$ELSE}
  238.  {$R *.R16}
  239. {$ENDIF}
  240.  
  241. uses SysUtils, Printers {$IFNDEF GXE}, VCLUtils {$ENDIF};
  242.  
  243. {$IFDEF GXE}
  244. procedure Register;
  245. begin
  246.   RegisterComponents('Additional', [TFontComboBox, TColorComboBox]);
  247. end;
  248. {$ENDIF GXE}
  249.  
  250. {$IFNDEF WIN32}
  251. type
  252.   DWORD = Longint;
  253. {$ENDIF}
  254.  
  255. { Utility routines }
  256.  
  257. function CreateBitmap(ResName: PChar): TBitmap;
  258. begin
  259. {$IFDEF GXE}
  260.   Result := TBitmap.Create;
  261.   Result.Handle := LoadBitmap(HInstance, ResName);
  262. {$ELSE}
  263.   Result := MakeModuleBitmap(HInstance, ResName);
  264.   if Result = nil then ResourceNotFound(ResName);
  265. {$ENDIF GXE}
  266. end;
  267.  
  268. function GetItemHeight(Font: TFont): Integer;
  269. var
  270.   DC: HDC;
  271.   SaveFont: HFont;
  272.   Metrics: TTextMetric;
  273. begin
  274.   DC := GetDC(0);
  275.   try
  276.     SaveFont := SelectObject(DC, Font.Handle);
  277.     GetTextMetrics(DC, Metrics);
  278.     SelectObject(DC, SaveFont);
  279.   finally
  280.     ReleaseDC(0, DC);
  281.   end;
  282.   Result := Metrics.tmHeight + 1;
  283. end;
  284.  
  285. { TOwnerDrawComboBox }
  286.  
  287. constructor TOwnerDrawComboBox.Create(AOwner: TComponent);
  288. begin
  289.   inherited Create(AOwner);
  290.   inherited Style := csDropDownList;
  291.   FStyle := csDropDownList;
  292. end;
  293.  
  294. procedure TOwnerDrawComboBox.SetComboStyle(Value: TOwnerDrawComboStyle);
  295. begin
  296.   if FStyle <> Value then begin
  297.     FStyle := Value;
  298.     inherited Style := Value;
  299.   end;
  300. end;
  301.  
  302. function TOwnerDrawComboBox.MinItemHeight: Integer;
  303. begin
  304.   Result := GetItemHeight(Font);
  305.   if Result < 9 then Result := 9;
  306. end;
  307.  
  308. procedure TOwnerDrawComboBox.ResetItemHeight;
  309. var
  310.   H: Integer;
  311. begin
  312.   H := MinItemHeight;
  313.   FItemHeightChanging := True;
  314.   try
  315.     inherited ItemHeight := H;
  316.   finally
  317.     FItemHeightChanging := False;
  318.   end;
  319.   if HandleAllocated then SendMessage(Handle, CB_SETITEMHEIGHT, 0, H);
  320. end;
  321.  
  322. procedure TOwnerDrawComboBox.CreateParams(var Params: TCreateParams);
  323. const
  324.   ComboBoxStyles: array[TOwnerDrawComboStyle] of DWORD =
  325.     (CBS_DROPDOWN, CBS_SIMPLE, CBS_DROPDOWNLIST);
  326. begin
  327.   inherited CreateParams(Params);
  328.   with Params do
  329.     Style := (Style and not CBS_DROPDOWNLIST) or CBS_OWNERDRAWFIXED or
  330.       ComboBoxStyles[FStyle];
  331. end;
  332.  
  333. procedure TOwnerDrawComboBox.CreateWnd;
  334. begin
  335.   inherited CreateWnd;
  336.   ResetItemHeight;
  337. end;
  338.  
  339. procedure TOwnerDrawComboBox.CMFontChanged(var Message: TMessage);
  340. begin
  341.   inherited;
  342.   ResetItemHeight;
  343.   RecreateWnd;
  344. end;
  345.  
  346. {$IFDEF WIN32}
  347. procedure TOwnerDrawComboBox.CMRecreateWnd(var Message: TMessage);
  348. begin
  349.   if not FItemHeightChanging then
  350.     inherited;
  351. end;
  352. {$ENDIF}
  353.  
  354. { TColorComboBox }
  355.  
  356. const
  357.   ColorsInList = 16;
  358.   ColorValues: array [0..ColorsInList - 1] of TColor = (
  359.     clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
  360.     clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
  361.  
  362. constructor TColorComboBox.Create(AOwner: TComponent);
  363. begin
  364.   inherited Create(AOwner);
  365.   FColorValue := clBlack;  { make default color selected }
  366.   FColorNames := TStringList.Create;
  367.   TStringList(FColorNames).OnChange := ColorNamesChanged;
  368.   FDisplayNames := True;
  369. end;
  370.  
  371. destructor TColorComboBox.Destroy;
  372. begin
  373.   TStringList(FColorNames).OnChange := nil;
  374.   FColorNames.Free;
  375.   FColorNames := nil;
  376.   inherited Destroy;
  377. end;
  378.  
  379. procedure TColorComboBox.CreateWnd;
  380. begin
  381.   inherited CreateWnd;
  382.   PopulateList;
  383.   SetColorValue(FColorValue);
  384. end;
  385.  
  386. procedure TColorComboBox.PopulateList;
  387. var
  388.   I: Integer;
  389.   ColorName: string;
  390. begin
  391.   Items.BeginUpdate;
  392.   try
  393.     Clear;
  394.     for I := 0 to Pred(ColorsInList) do begin
  395.       if (I <= Pred(FColorNames.Count)) and (FColorNames[I] <> '') then
  396.         ColorName := FColorNames[I]
  397.       else
  398.         { delete two first characters which prefix "cl" educated }
  399.         ColorName := Copy(ColorToString(ColorValues[I]), 3, MaxInt);
  400.       Items.AddObject(ColorName, TObject(ColorValues[I]));
  401.     end;
  402.   finally
  403.     Items.EndUpdate;
  404.   end;
  405. end;
  406.  
  407. procedure TColorComboBox.ColorNamesChanged(Sender: TObject);
  408. begin
  409.   if HandleAllocated then begin
  410.     FColorValue := ColorValue;
  411.     RecreateWnd;
  412.   end;
  413. end;
  414.  
  415. procedure TColorComboBox.SetColorNames(Value: TStrings);
  416. begin
  417.   FColorNames.Assign(Value);
  418. end;
  419.  
  420. procedure TColorComboBox.SetDisplayNames(Value: Boolean);
  421. begin
  422.   if DisplayNames <> Value then begin
  423.     FDisplayNames := Value;
  424.     Invalidate;
  425.   end;
  426. end;
  427.  
  428. function TColorComboBox.GetColorValue: TColor;
  429. var
  430.   I: Integer;
  431. begin
  432.   Result := FColorValue;
  433.   if (Style <> csDropDownList) and (ItemIndex < 0) then begin
  434.     I := Items.IndexOf(inherited Text);
  435.     if I >= 0 then Result := TColor(Items.Objects[I])
  436.     else begin
  437.       Val(inherited Text, Result, I);
  438.       if I <> 0 then Result := FColorValue;
  439.     end;
  440.   end;
  441. end;
  442.  
  443. procedure TColorComboBox.SetColorValue(NewValue: TColor);
  444. var
  445.   Item: Integer;
  446.   CurrentColor: TColor;
  447.   S: string;
  448. begin
  449.   if (ItemIndex < 0) or (NewValue <> FColorValue) then begin
  450.     FColorValue := NewValue;
  451.     { change selected item }
  452.     for Item := 0 to Pred(Items.Count) do begin
  453.       CurrentColor := TColor(Items.Objects[Item]);
  454.       if CurrentColor = NewValue then begin
  455.         if ItemIndex <> Item then ItemIndex := Item;
  456.         DoChange;
  457.         Exit;
  458.       end;
  459.     end;
  460.     if Style = csDropDownList then
  461.       ItemIndex := -1
  462.     else begin
  463.       S := ColorToString(NewValue);
  464.       if Pos('cl', S) = 1 then System.Delete(S, 1, 2);
  465.       inherited Text := S;
  466.     end;
  467.     DoChange;
  468.   end;
  469. end;
  470.  
  471. procedure TColorComboBox.DrawItem(Index: Integer; Rect: TRect;
  472.   State: TOwnerDrawState);
  473. const
  474.   ColorWidth = 22;
  475. var
  476.   ARect: TRect;
  477.   Text: array[0..255] of Char;
  478.   Safer: TColor;
  479. begin
  480.   ARect := Rect;
  481.   Inc(ARect.Top, 2);
  482.   Inc(ARect.Left, 2);
  483.   Dec(ARect.Bottom, 2);
  484.   if FDisplayNames then ARect.Right := ARect.Left + ColorWidth
  485.   else Dec(ARect.Right, 3);
  486.   with Canvas do begin
  487.     FillRect(Rect);
  488.     Safer := Brush.Color;
  489.     Pen.Color := clWindowText;
  490.     Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
  491.     Brush.Color := TColor(Items.Objects[Index]);
  492.     try
  493.       InflateRect(ARect, -1, -1);
  494.       FillRect(ARect);
  495.     finally
  496.       Brush.Color := Safer;
  497.     end;
  498.     if FDisplayNames then begin
  499.       StrPCopy(Text, Items[Index]);
  500.       Rect.Left := Rect.Left + ColorWidth + 6;
  501.       DrawText(Canvas.Handle, Text, StrLen(Text), Rect,
  502. {$IFDEF RX_D4}
  503.         DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
  504. {$ELSE}
  505.         DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  506. {$ENDIF}
  507.     end;
  508.   end;
  509. end;
  510.  
  511. procedure TColorComboBox.Change;
  512. var
  513.   AColor: TColor;
  514. begin
  515.   inherited Change;
  516.   AColor := GetColorValue;
  517.   if FColorValue <> AColor then begin
  518.     FColorValue := AColor;
  519.     DoChange;
  520.   end;
  521. end;
  522.  
  523. procedure TColorComboBox.Click;
  524. begin
  525.   if ItemIndex >= 0 then ColorValue := TColor(Items.Objects[ItemIndex]);
  526.   inherited Click;
  527. end;
  528.  
  529. procedure TColorComboBox.DoChange;
  530. begin
  531.   if not (csReading in ComponentState) then
  532.     if Assigned(FOnChange) then FOnChange(Self);
  533. end;
  534.  
  535. { TFontComboBox }
  536.  
  537. const
  538.   WRITABLE_FONTTYPE = 256;
  539.  
  540. function IsValidFont(Box: TFontComboBox; LogFont: TLogFont;
  541.   FontType: Integer): Boolean;
  542. begin
  543.   Result := True;
  544.   if (foAnsiOnly in Box.Options) then
  545.     Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  546.   if (foTrueTypeOnly in Box.Options) then
  547.     Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  548.   if (foFixedPitchOnly in Box.Options) then
  549.     Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  550.   if (foOEMFontsOnly in Box.Options) then
  551.     Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  552.   if (foNoOEMFonts in Box.Options) then
  553.     Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  554.   if (foNoSymbolFonts in Box.Options) then
  555.     Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  556.   if (foScalableOnly in Box.Options) then
  557.     Result := Result and (FontType and RASTER_FONTTYPE = 0);
  558. end;
  559.  
  560. {$IFDEF WIN32}
  561.  
  562. function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  563.   var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  564.   export; stdcall;
  565. var
  566.   FaceName: string;
  567. begin
  568.   FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  569.   with TFontComboBox(Data) do
  570.     if (Items.IndexOf(FaceName) < 0) and
  571.       IsValidFont(TFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
  572.     begin
  573.       if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
  574.         FontType := FontType or WRITABLE_FONTTYPE;
  575.       Items.AddObject(FaceName, TObject(FontType));
  576.     end;
  577.   Result := 1;
  578. end;
  579.  
  580. {$ELSE}
  581.  
  582. function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  583.   FontType: Integer; Data: Pointer): Integer; export;
  584. begin
  585.   with TFontComboBox(Data) do
  586.     if (Items.IndexOf(StrPas(LogFont.lfFaceName)) < 0) and
  587.       IsValidFont(TFontComboBox(Data), LogFont, FontType) then
  588.     begin
  589.       if LogFont.lfCharSet = SYMBOL_CHARSET then
  590.         FontType := FontType or WRITABLE_FONTTYPE;
  591.       Items.AddObject(StrPas(LogFont.lfFaceName), TObject(FontType));
  592.     end;
  593.   Result := 1;
  594. end;
  595.  
  596. {$ENDIF WIN32}
  597.  
  598. constructor TFontComboBox.Create(AOwner: TComponent);
  599. begin
  600.   inherited Create(AOwner);
  601.   FTrueTypeBMP := CreateBitmap('TRUETYPE_FNT');
  602.   FDeviceBMP := CreateBitmap('DEVICE_FNT');
  603.   FDevice := fdScreen;
  604.   Sorted := True;
  605.   inherited ItemHeight := MinItemHeight;
  606. end;
  607.  
  608. destructor TFontComboBox.Destroy;
  609. begin
  610.   FTrueTypeBMP.Free;
  611.   FDeviceBMP.Free;
  612.   inherited Destroy;
  613. end;
  614.  
  615. procedure TFontComboBox.CreateWnd;
  616. var
  617.   OldFont: TFontName;
  618. begin
  619.   OldFont := FontName;
  620.   inherited CreateWnd;
  621.   FUpdate := True;
  622.   try
  623.     PopulateList;
  624.     inherited Text := '';
  625.     SetFontName(OldFont);
  626.   finally
  627.     FUpdate := False;
  628.   end;
  629.   if AnsiCompareText(FontName, OldFont) <> 0 then DoChange;
  630. end;
  631.  
  632. procedure TFontComboBox.PopulateList;
  633. var
  634.   DC: HDC;
  635. {$IFNDEF WIN32}
  636.   Proc: TFarProc;
  637. {$ENDIF}
  638. begin
  639.   if not HandleAllocated then Exit;
  640.   Items.BeginUpdate;
  641.   try
  642.     Clear;
  643.     DC := GetDC(0);
  644.     try
  645. {$IFDEF WIN32}
  646.       if (FDevice = fdScreen) or (FDevice = fdBoth) then
  647.         EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
  648.       if (FDevice = fdPrinter) or (FDevice = fdBoth) then
  649.       try
  650.         EnumFontFamilies(Printer.Handle, nil, @EnumFontsProc, Longint(Self));
  651.       except
  652.         { skip any errors }
  653.       end;
  654. {$ELSE}
  655.       Proc := MakeProcInstance(@EnumFontsProc, HInstance);
  656.       try
  657.         if (FDevice = fdScreen) or (FDevice = fdBoth) then
  658.           EnumFonts(DC, nil, Proc, PChar(Self));
  659.         if (FDevice = fdPrinter) or (FDevice = fdBoth) then
  660.           try
  661.             EnumFonts(Printer.Handle, nil, Proc, PChar(Self));
  662.           except
  663.             { skip any errors }
  664.           end;
  665.       finally
  666.         FreeProcInstance(Proc);
  667.       end;
  668. {$ENDIF}
  669.     finally
  670.       ReleaseDC(0, DC);
  671.     end;
  672.   finally
  673.     Items.EndUpdate;
  674.   end;
  675. end;
  676.  
  677. procedure TFontComboBox.SetFontName(const NewFontName: TFontName);
  678. var
  679.   Item: Integer;
  680. begin
  681.   if FontName <> NewFontName then begin
  682.     if not (csLoading in ComponentState) then begin
  683.       HandleNeeded;
  684.       { change selected item }
  685.       for Item := 0 to Items.Count - 1 do
  686.         if AnsiCompareText(Items[Item], NewFontName) = 0 then begin
  687.           ItemIndex := Item;
  688.           DoChange;
  689.           Exit;
  690.         end;
  691.       if Style = csDropDownList then ItemIndex := -1
  692.       else inherited Text := NewFontName;
  693.     end
  694.     else inherited Text := NewFontName;
  695.     DoChange;
  696.   end;
  697. end;
  698.  
  699. function TFontComboBox.GetFontName: TFontName;
  700. begin
  701.   Result := inherited Text;
  702. end;
  703.  
  704. function TFontComboBox.GetTrueTypeOnly: Boolean;
  705. begin
  706.   Result := foTrueTypeOnly in FOptions;
  707. end;
  708.  
  709. procedure TFontComboBox.SetOptions(Value: TFontListOptions);
  710. begin
  711.   if Value <> Options then begin
  712.     FOptions := Value;
  713.     Reset;
  714.   end;
  715. end;
  716.  
  717. procedure TFontComboBox.SetTrueTypeOnly(Value: Boolean);
  718. begin
  719.   if Value <> TrueTypeOnly then begin
  720.     if Value then FOptions := FOptions + [foTrueTypeOnly]
  721.     else FOptions := FOptions - [foTrueTypeOnly];
  722.     Reset;
  723.   end;
  724. end;
  725.  
  726. procedure TFontComboBox.SetDevice(Value: TFontDevice);
  727. begin
  728.   if Value <> FDevice then begin
  729.     FDevice := Value;
  730.     Reset;
  731.   end;
  732. end;
  733.  
  734. procedure TFontComboBox.SetUseFonts(Value: Boolean);
  735. begin
  736.   if Value <> FUseFonts then begin
  737.     FUseFonts := Value;
  738.     Invalidate;
  739.   end;
  740. end;
  741.  
  742. procedure TFontComboBox.DrawItem(Index: Integer; Rect: TRect;
  743.   State: TOwnerDrawState);
  744. var
  745.   Bitmap: TBitmap;
  746.   BmpWidth: Integer;
  747.   Text: array[0..255] of Char;
  748. begin
  749.   with Canvas do begin
  750.     FillRect(Rect);
  751.     BmpWidth  := 20;
  752.     if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
  753.       Bitmap := FTrueTypeBMP
  754.     else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
  755.       Bitmap := FDeviceBMP
  756.     else Bitmap := nil;
  757.     if Bitmap <> nil then begin
  758.       BmpWidth := Bitmap.Width;
  759.       BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
  760.         div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
  761.         Bitmap.Height), Bitmap.TransparentColor);
  762.     end;
  763.     { uses DrawText instead of TextOut in order to get clipping against
  764.       the combo box button }
  765.     {TextOut(Rect.Left + bmpWidth + 6, Rect.Top, Items[Index])}
  766.     StrPCopy(Text, Items[Index]);
  767.     Rect.Left := Rect.Left + BmpWidth + 6;
  768.     if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
  769.       Font.Name := Items[Index];
  770.     DrawText(Handle, Text, StrLen(Text), Rect,
  771. {$IFDEF RX_D4}
  772.       DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
  773. {$ELSE}
  774.       DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  775. {$ENDIF}
  776.   end;
  777. end;
  778.  
  779. procedure TFontComboBox.WMFontChange(var Message: TMessage);
  780. begin
  781.   inherited;
  782.   Reset;
  783. end;
  784.  
  785. function TFontComboBox.MinItemHeight: Integer;
  786. begin
  787.   Result := inherited MinItemHeight;
  788.   if Result < FTrueTypeBMP.Height - 1 then
  789.     Result := FTrueTypeBMP.Height - 1;
  790. end;
  791.  
  792. procedure TFontComboBox.Change;
  793. var
  794.   I: Integer;
  795. begin
  796.   inherited Change;
  797.   if Style <> csDropDownList then begin
  798.     I := Items.IndexOf(inherited Text);
  799.     if (I >= 0) and (I <> ItemIndex) then begin
  800.       ItemIndex := I;
  801.       DoChange;
  802.     end;
  803.   end;
  804. end;
  805.  
  806. procedure TFontComboBox.Click;
  807. begin
  808.   inherited Click;
  809.   DoChange;
  810. end;
  811.  
  812. procedure TFontComboBox.DoChange;
  813. begin
  814.   if not (csReading in ComponentState) then
  815.     if not FUpdate and Assigned(FOnChange) then FOnChange(Self);
  816. end;
  817.  
  818. procedure TFontComboBox.Reset;
  819. var
  820.   SaveName: TFontName;
  821. begin
  822.   if HandleAllocated then begin
  823.     FUpdate := True;
  824.     try
  825.       SaveName := FontName;
  826.       PopulateList;
  827.       FontName := SaveName;
  828.     finally
  829.       FUpdate := False;
  830.       if FontName <> SaveName then DoChange;
  831.     end;
  832.   end;
  833. end;
  834.  
  835. end.