controls/enhcombos/KOLFontComboBox.pas

   1 unit KOLFontComboBox;
   2 {* Font combobox is usefull for selecting font names ,
   3  becouse visually express each font (only screen fonts).
   4  |<br>
   5  If font is TrueType small TT icon is created before font name.
   6  |<br>
   7  |<br>
   8  |<i> Author : Boguslaw Brandys </i>
   9  |<br>
  10  |<i> Email : brandysb@poczta.onet.pl </i>
  11
  12  }
  13
  14
  15
  16 interface
  17 uses
  18   Windows, Messages, KOL;
  19
  20 {$R KOLFontComboBox.res}
  21
  22
  23 type
  24
  25
  26   PFontCombo =^TFontCombo;
  27   TKOLFontComboBox = PFontCombo;
  28   TFontCombo = object(TObj)
  29   {*}
  30   private
  31     { Private declarations }
  32     fControl : PControl;
  33     fOnChange: TOnEvent;
  34     fAOwner: PControl;
  35     fFontName : String;
  36     fFontHeight : Integer;
  37     fCursor : HCURSOR;
  38     TTImage : HICON;
  39   procedure DoChange(Obj : PObj);
  40   procedure DestroyFontList;
  41   procedure MakeFontList;
  42   function GetColor : TColor;
  43   procedure SetColor(Value : TColor);
  44   procedure SetFontHeight(const Value : Integer);
  45   procedure SetFontName(const Value : String);
  46   procedure SetCursor(const Value : HCURSOR);
  47         function DrawOneItem(Sender: PObj; DC: HDC;
  48         const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction;
  49         ItemState: TDrawState): Boolean;
  50         protected
  51                 { Protected declarations }
  52         public
  53                 { Public declarations }
  54                 destructor Destroy; virtual;
  55                 {*}
  56                 function SetAlign(Value: TControlAlign): PFontCombo; overload;
  57                 {*}
  58                 function SetPosition(X, Y: integer): PFontCombo; overload;
  59                 {*}
  60                 function SetSize(X, Y: integer): PFontCombo; overload;
  61                 {*}
  62                 property Color : TColor read GetColor write SetColor;
  63                 {*}
  64                 property FontName : String read fFontName write SetFontName;
  65                 {* Return selected font name , beside when is set combo is positioned to equal font name}
  66                 property FontHeight : Integer read fFontHeight write SetFontHeight;
  67                 {* For adjust size of displayed font names}
  68                 property OnChange: TOnEvent read fOnChange write fOnChange;
  69                 {* Fired when font is changed}
  70                 property Cursor : HCURSOR read fCursor write SetCursor;
  71                 {* To select cursor}
  72
  73         end;
  74
  75
  76 function NewFontComboBox( AOwner: PControl): PFontCombo;
  77 {* Creates new font combobox which is generally an opaque for KOL combobox
  78 with additional processing of font's list}
  79
  80
  81
  82 implementation
  83
  84 //uses objects;
  85
  86 type
  87         TFontDef = packed record
  88                 Handle: DWORD;
  89                 TrueType: Boolean;
  90         end;
  91         PFontDef = ^TFontDef;
  92
  93
  94 function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  95         var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  96         export; stdcall;
  97 var
  98         FaceName: string;
  99         control : PFontCombo;
 100         font : HFONT;
 101         i  : Integer;
 102         //j  : LongInt;
 103         FD: PFontDef;
 104 begin
 105         control  := PFontCombo(Data);
 106         FaceName := String(EnumLogFont.elfLogFont.lfFaceName);
 107         with EnumLogFont do begin
 108         elfLogFont.lfHeight := -control.fFontHeight;
 109         elfLogFont.lfWidth  := 0;
 110         end;
 111         if control.fControl.IndexOf(FaceName) < 0 then
 112         begin
 113                 if EnumLogFont.elflogfont.lfCharSet = SYMBOL_CHARSET then font :=0
 114                 else
 115                 font := CreateFontIndirect(EnumLogFont.elfLogFont);
 116                 i := control.fcontrol.Add(FaceName);
 117                 //j := LongInt(font);
 118                 {if (FontType and TRUETYPE_FONTTYPE) <> 0 then
 119                         j := -j;}
 120                 GetMem( FD, Sizeof( FD^ ) );
 121                 FD.Handle := font;
 122                 FD.TrueType := (FontType and TRUETYPE_FONTTYPE) <> 0;
 123                 control.fcontrol.ItemData[i] := DWORD( FD );
 124         end;
 125         Result := 1;
 126 end;
 127
 128
 129
 130
 131
 132 function NewFontComboBox;
 133 var
 134          p: PFontCombo;
 135                 c: PControl;
 136 begin
 137          c:=NewComboBox(AOwner,[coReadOnly,coSort,coOwnerDrawVariable]);
 138          New(p,create);
 139          AOwner.Add2AutoFree(p);
 140          p.fControl:= c;
 141          p.fAOwner:=AOwner;
 142          p.fFontHeight := 11;
 143          p.fControl.Font.FontName := 'MS Sans Serif';
 144          p.fControl.Font.FontHeight := 11;
 145          p.TTImage := LoadIcon(hInstance,'TTICON');
 146          p.fCursor := LoadCursor(0,IDC_ARROW);
 147          p.Color  := clWindow;
 148          p.fControl.OnDrawItem := p.DrawOneItem;
 149          p.MakeFontList;
 150          p.fControl.OnChange:=p.DoChange;
 151          p.fControl.CurIndex :=0;
 152          Result:=p;
 153 end;
 154
 155
 156 procedure TFontCombo.DoChange(Obj : PObj);
 157 begin
 158         fFontName := fControl.Items[fControl.CurIndex];
 159         if Assigned(fOnChange) then fOnChange(@Self);
 160 end;
 161
 162
 163 function TFontCombo.SetAlign(Value: TControlAlign): PFontCombo;
 164 begin
 165         fControl.Align:=Value;
 166         Result:=@Self;
 167 end;
 168
 169 function TFontCombo.SetPosition(X, Y: integer): PFontCombo;
 170 begin
 171          fControl.Left := X;
 172          fControl.Top := Y;
 173          Result := @self;
 174 end;
 175
 176 function TFontCombo.SetSize(X, Y: integer): PFontCombo;
 177 begin
 178          fControl.Width  := X;
 179          fControl.Height := Y;
 180          Result := @self;
 181 end;
 182
 183
 184 function TFontCombo.GetColor : TColor;
 185 begin
 186         Result := fControl.Color;
 187 end;
 188
 189
 190 procedure TFontCombo.SetColor(Value : TColor);
 191 begin
 192         fControl.Color := Value;
 193 end;
 194
 195 procedure TFontCombo.SetFontName(const Value : String);
 196 var
 197 i : Integer;
 198 begin
 199                 i:= fControl.IndexOf(Value);
 200                 if i  > 0 then
 201                                 begin
 202                                                 fFontName := Value;
 203                                                 fControl.BeginUpdate;
 204                                                 fControl.CurIndex := i;
 205                                                 fControl.EndUpdate;
 206                                         end
 207                                 else
 208                                 begin
 209                                                 fFontName := '???';
 210                                                 fControl.Text := '???';
 211                                 end;
 212
 213
 214 end;
 215
 216
 217 procedure TFontCombo.SetFontHeight(const Value : Integer);
 218 begin
 219                 if (Value <> fFontHeight) then
 220                                 begin
 221                                                 fFontHeight := Value;
 222                                                 MakeFontList;
 223                                 end;
 224 end;
 225
 226 procedure TFontCombo.SetCursor(const Value : HCURSOR);
 227 begin
 228                 fCursor := Value;
 229         fControl.Cursor := Value;
 230 end;
 231
 232
 233 function TFontCombo.DrawOneItem(Sender: PObj; DC: HDC;
 234         const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction;
 235         ItemState: TDrawState): Boolean;
 236 var
 237 xRect : TRect;
 238 xfont : HFONT;
 239 //j : LongInt;
 240 FD: PFontDef;
 241 begin
 242 if ItemIdx > -1 then begin
 243 //j := Sender.ItemData[ItemIdx];
 244 FD := Pointer( PControl(Sender).ItemData[ItemIdx] );
 245 xRect := Rect;
 246 FillRect(DC,Rect,0);
 247 // if j < 0  then
 248     if FD.TrueType then
 249     begin
 250         DrawIcon(DC,Rect.Left+2,Rect.Top+1,TTImage);
 251         // j := -j;
 252         end;
 253 //xfont := HFONT(j);
 254 xfont := FD.Handle;
 255 xRect.Left := xRect.Left + 20;
 256 if xfont <> 0 then SelectObject(DC,xfont)
 257 else
 258                 SelectObject(DC,PControl(Sender).Font.Handle);
 259 DrawText(DC,PChar(PControl(Sender).Items[ItemIdx]),Length(PControl(Sender).Items[ItemIdx]),xRect,DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
 260 if (odaSelect in DrawAction) then InvertRect(DC,Rect);
 261 end;
 262 Result := False;
 263 end;
 264
 265
 266
 267 procedure  TFontCombo.DestroyFontList;
 268 var
 269 i    : Integer;
 270 xfont : HFONT;
 271 //j  : LongInt;
 272 FD: PFontDef;
 273 begin
 274         for i:= 0 to  fControl.Count -1 do
 275    begin
 276    //j := fControl.ItemData[i];
 277    // if j < 0 then j := -j;
 278    FD := Pointer( fControl.ItemData[i] );
 279    //xfont := HFONT(j);
 280    xfont := FD.Handle;
 281    FreeMem( FD );
 282    //
 283    if xfont <> 0 then DeleteObject(xfont);
 284    end;
 285    fControl.Clear;
 286 end;
 287
 288 destructor TFontCombo.Destroy;
 289 begin
 290   fFontName := '';
 291                 DestroyFontList;
 292   /////////////////////////////
 293   //      CloseHandle(TTImage);
 294   //////////////////////////////
 295      DestroyIcon( TTImage ); //
 296   //////////////////////////////
 297         fControl.Free;
 298                 inherited;
 299 end;
 300
 301
 302
 303
 304
 305 procedure TFontCombo.MakeFontList;
 306 var
 307 DC : HDC;
 308 begin
 309          DestroyFontList;
 310     DC := GetDC(0);
 311     fControl.BeginUpdate;
 312         try
 313             EnumFontFamilies(DC,nil,@EnumFontsProc,LongInt(@Self));
 314         finally
 315             ReleaseDC(0,DC);
 316             fControl.EndUpdate;
 317         end;
 318
 319 end;
 320
 321 end.