unit TdkFontComboBox;
{
       Unit: TdkFontcombo
    purpose: Improved KOL Font combobox
     Author: Thaddy de Koning
  Copyright: None
    Remarks: based on code by Boguslav Brandys, but almost everything has
    changed.
    Basic processing not changed except for use of NewFont,
    now much simpler.
    Turned into a real TControl;
    The original needed an Icon resource,
    this one takes icons for truetype, vector and Opentype from "fontex.dll".
    which should be present on all systems from win95.
    If XP or 2000 then OpenType fonts are supported.

    Thaddy

    Revisions:
    Version 1.01: Added wndprocFontCombo, so Onchange stays available
    Version 1.02: Cleaned up
}

interface

uses
  Windows, Messages, KOL;

type


  PFontComboData = ^TFontComboData;
  TFontComboData = object(Tobj)
   Fowner:PControl;
   ICOpenType,
   ICTrueType,
   ICVector,
   ICRaster:PIcon;
   destructor destroy;virtual;
   function DrawOneItem(Sender: PObj; DC: HDC;
      const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction;
      ItemState: TDrawState): Boolean;
  end;



function NewFontComboBox(AOwner: PControl): PControl;


implementation

uses
  objects;

const

 FT_RASTER   = 0;
 FT_VECTOR   = 1;
 FT_TRUETYPE = 2;
 FT_OPENTYPE = 3;

function WndprocFontCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
                          : Boolean;
var
 struct:TDrawItemStruct;
 States:TDrawAction;
 Action:TDrawstate;
 DC:HDC;
begin
  Result:=False;
  if (msg.message = WM_COMMAND) and (HIWORD(msg.wparam) = CBN_SELCHANGE) then
    sender.font.Assign(PGraphicTool(sender.Itemdata[sender.CurIndex]));
end;

function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;stdcall;
var
  FaceName: String;
  control: PControl;
  i: Integer;
  Font:pGraphicTool;
begin
  Font:=NewFont;
  Applet.Add2AutoFree(Font);
  Font.tag:=Fonttype;
  if Fonttype = 0 then Font.tag:=FT_VECTOR else
  if fonttype = RASTER_FONTTYPE then font.tag := FT_RASTER else
  if FontType = TRUETYPE_FONTTYPE then Font.tag := FT_TRUETYPE;
  If (WinVer > WvNT) and (Getbits(TextMetric.ntmFlags,17,18) > 0) then
    Font.tag:=FT_OPENTYPE;
  Control := PControl(Data);
  FaceName := String(EnumLogFont.elfLogFont.lfFaceName);
  with EnumLogFont do
  begin
    elfLogFont.lfHeight := Control.font.FontHeight;
    elfLogFont.lfWidth := 0;
  end;
  if (Control.count = 0) or (Control.IndexOf(FaceName) < 0) then
  begin
    if EnumLogFont.elflogfont.lfCharSet = SYMBOL_CHARSET then
      font.AssignHandle(0)
    else
      font.Assignhandle(CreateFontIndirect(EnumLogFont.elfLogFont));
    i := Control.Add(FaceName);
    Control.ItemData[i] := Cardinal(Font);
  end;
  Result := 1;
end;

function NewFontComboBox;
var
  h:Thandle;
  Data:PFontcombodata;
begin
  New(Data,create);
  Result := NewComboBox(AOwner, [coReadOnly, coSort, coOwnerDrawVariable]);
  with Result^ do
  begin
    Color:=clWindow;
    Data.Fowner:=Result;
    CustomObj:=Data;
    H:=LoadLibrary('fontext.dll');
    if H <> 0 then
    with Data^ do
    begin
      ICTruetype:= NewIcon;
      ICTruetype.LoadFromResourceID(H,2,16);
      ICRaster:= NewIcon;
      ICRaster.LoadFromResourceID(H,3,16);
      ICVector:= NewIcon;
      ICOpenType:= NewIcon;
      if WinVer > WvNT then
      begin
        ICVector.LoadFromResourceID(H,5,16);
        ICOpentype.LoadFromResourceID(H,6,16)
      end
      else
      begin
        ICOpentype.LoadFromResourceID(H,2,16); // prevent dll hell
        ICVector.LoadFromResourceID(H,3,16);
      end;
    end;
    FreeLibrary(H);
    OnDrawItem := Data.DrawOneItem;
    CurIndex:=IndexOf(Parent.Font.FontName);
    AttachProc(WndProcFontCombo);
    EnumFontFamilies(Result.canvas.handle, NIL, @EnumFontsProc, LongInt(Result));
 end
end;

function TFontComboData.DrawOneItem(Sender: PObj; DC: HDC;
  const Rect: TRect; ItemIdx: Integer; DrawAction: TDrawAction;
  ItemState: TDrawState): Boolean;
var
  xRect: TRect;
  xfont: HFONT;
  FD:  pGraphictool;
begin
  if ItemIdx > -1 then
  begin
    FD := Pointer(pControl(Sender).ItemData[ItemIdx]);
    xRect := Rect;
    InFlateRect(xRect,-1,-1);
    FillRect(DC, Rect, 0);
    if FD.Tag = FT_TRUETYPE then
      DrawIconEx(DC, Rect.Left + 1,Rect.Top,ICTruetype.handle,16,16,0,0,DI_NORMAL)
    else if FD.Tag = FT_OPENTYPE then
      DrawIconEx(DC, Rect.Left + 1,Rect.Top,ICOpentype.handle,16,16,0,0,DI_NORMAL)
    else if FD.tag = FT_RASTER then
      DrawIconEx(DC, Rect.Left + 1,Rect.Top,ICRaster.handle,16,16,0,0,DI_NORMAL)
    else if FD.tag = FT_VECTOR then
      DrawIconEx(DC, Rect.Left + 1,Rect.Top,ICVector.handle,16,16,0,0,DI_NORMAL);

    xfont := FD.Handle;
    xRect.Left := xRect.Left + 20;
    if xfont <> 0 then
        SelectObject(DC, xfont)
    else
      SelectObject(DC, pControl(Sender).Font.Handle);
    DrawText(DC, PChar(pControl(Sender).Items[ItemIdx]),
      Length(pControl(Sender).Items[ItemIdx]), xRect,
      DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
    if (odaSelect in DrawAction) then InvertRect(DC, Rect);
  end;
  Result := true;
end;

destructor TFontComboData.Destroy;
begin
  IcTruetype.free;
  ICRaster.free;
  IcOpenType.free;
  IcVector.Free;
  inherited;
end;

end.