unit KOLFontEditor;
{
==================================================================

                  TKOLFont Property Editor
                          for MCK

          -----------------------------------------------
          Version:  1.0
          Date:     16-sep-2003
          Author:   (C) Alexander Pravdin (aka SPeller)
          e-mail:   speller@mail.primorye.ru
          www:      http://kol.mastak.ru
                    http://bonanzas.rinet.ru

          Thanks to:
          Dmitry Zharov (aka Gandalf):
                    Start point of this component (MHFontDialog).
                    Delphi 5 and Delphi 7 support.

          Tested Delphi versions: 5, 6, 7.

==================================================================}

interface

{$I KOLDEF.INC}

uses KOL, Windows, Messages, Graphics, Forms, CommDlg, Mirror,
{$IFDEF _D6orHigher}
  DesignEditors, DesignIntf;
{$ELSE}
  DsgnIntf;
{$ENDIF}

type

  TKOLFontProperty = class(TClassProperty)
  private
    DlgWnd,
      hWndOwner,
      LabelWnd,
      PickWnd,
      FontLWnd,
      EditWnd,
      CBWnd: HWND;
    ColorDlg: PColorDialog;
    Top, Left, Height, Width,
      OldPickWndProc,
      OldEditWndProc: Integer;
    Colors: PList;
    Font: TFont;
    Color: Integer;
    function DlgExecute: Boolean;
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
  end;

procedure Register;

implementation

const
  ID_DLGOBJ         = 'ID_DLGOBJ'#0;
  DLG_LBLID         = 11200;
  DLG_PICKID        = 11201;
  DLG_EDITID        = 11202;
  DLG_COLORCB       = 1139;
  DLG_EFFECTSGROUP  = 1072;

  CN_APPLYCOLOR     = 501;

function PickWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
  _Self             : TKOLFontProperty;
  R                 : TRect;
  hBr, DC           : THandle;
begin
  _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
  with _Self do
  begin
    case Msg of
      WM_PAINT:
        begin
          GetClientRect(Wnd, R);
          CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
          hBr := CreateSolidBrush(Color);
          DC := GetDC(Wnd);
          FillRect(DC, R, hBr);
          ReleaseDC(Wnd, DC);
          DeleteObject(hBr);
          Result := 0;
          Exit;
        end;
    end;                  // case
    Result := CallWindowProc(Pointer(OldPickWndProc), Wnd, Msg, wParam, lParam);
  end;                    // with
end;

function EditWndProc(Wnd: HWND; Msg: Cardinal; wParam, lParam: Integer): Integer; stdcall;
var
  _Self             : TKOLFontProperty;
begin
  _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
  with _Self do
  begin
    Result := CallWindowProc(Pointer(OldEditWndProc), Wnd, Msg, wParam, lParam);
  end;                    // with
end;

function FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT; stdcall;
var
  _Self             : TKOLFontProperty;
  R, R2, SR         : TRect;
  I, tmID, CBCurSel, CBCount: Integer;
  PCF               : PChooseFontA;
  tmWnd, ChildWnd, hFont: THandle;
  st                : string;
  FR                : Boolean;
begin
  Result := 0;
  _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
  if (_Self = nil) and (Msg = WM_INITDIALOG) then
  begin
    PCF := Pointer(lParam);
    SetProp(Wnd, ID_DLGOBJ, Cardinal(PCF.lCustData));
    _Self := TKOLFontProperty(GetProp(Wnd, ID_DLGOBJ));
  end;

  with _Self do
  begin
    case Msg of
      WM_INITDIALOG:
        begin
          DlgWnd := Wnd;
          GetWindowRect(Wnd, R);
          SR := MakeRect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN));
          Width := R.Right - R.Left;
          Height := R.Bottom - R.Top + 0;
          Left := (SR.Left + SR.Right - Width) div 2;
          Top := (SR.Top + SR.Bottom - Height) div 2;
          SetWindowPos(Wnd, 0, Left, Top, Width, Height, SWP_NOZORDER);

          ChildWnd := 0;
          repeat
            ChildWnd := FindWindowEx(Wnd, ChildWnd, 'COMBOBOX', nil);
            tmID := GetWindowLong(ChildWnd, GWL_ID);
          until (tmID = DLG_COLORCB) or (ChildWnd = 0);
          if ChildWnd <> 0 then
          begin
            CBWnd := ChildWnd;
            GetWindowRect(CBWnd, R);
            R.Right := R.Right + 5;
            SetWindowPos(CBWnd, 0, 0, 0, R.Right - R.Left, R.Bottom - R.Top, SWP_NOZORDER or SWP_NOMOVE);
          end else
            Exit;

          ChildWnd := 0;
          repeat
            ChildWnd := FindWindowEx(Wnd, ChildWnd, 'BUTTON', nil);
            tmID := GetWindowLong(ChildWnd, GWL_ID);
          until (tmID = DLG_EFFECTSGROUP) or (ChildWnd = 0);
          if ChildWnd <> 0 then
          begin
            tmWnd := ChildWnd;
            GetWindowRect(tmWnd, R);
            ScreenToClient(Wnd, R.TopLeft);
            ScreenToClient(Wnd, R.BottomRight);
            R.Bottom := R.Bottom + 20;
            SetWindowPos(tmWnd, HWND_BOTTOM, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, 0);
          end else
            Exit;

          ChildWnd := 0;
          repeat
            ChildWnd := FindWindowEx(Wnd, ChildWnd, 'STATIC', nil);
            tmID := GetWindowLong(ChildWnd, GWL_ID);
          until (tmID = 1093) or (ChildWnd = 0);
          if ChildWnd <> 0 then
          begin
            FontLWnd := ChildWnd;
            GetWindowRect(FontLWnd, R2);
            R2 := MakeRect(7, 172, 219, 20);
            R2.Top := R2.Top + 25;
            R2.Bottom := R2.Bottom + 20;
            SetWindowPos(FontLWnd, 0, R2.Left, R2.Top, R2.Right - R2.Left, R2.Bottom - R2.Top, SWP_NOZORDER);
          end;

          LabelWnd := CreateWindow('STATIC', 'Exactly:',
            SS_LEFT or WS_VISIBLE or WS_CHILD,
            R.Left + 10, R.Bottom - 26, 40, 15,
            Wnd, 0, hInstance, nil);
          SetWindowLong(LabelWnd, GWL_ID, DLG_LBLID);
          SetProp(LabelWnd, ID_DLGOBJ, Cardinal(_Self));
          hFont := SendMessage(Wnd, WM_GETFONT, 0, 0);
          SendMessage(LabelWnd, WM_SETFONT, hFont, 0);

          if WinVer >= wvXP then
          begin
            I := 0;
            tmID := WS_BORDER;
          end else
          begin
            I := WS_EX_CLIENTEDGE;
            tmID := 0;
          end;
          PickWnd := CreateWindowEx(I,
            'STATIC', nil,
            WS_VISIBLE or WS_CHILD or SS_NOTIFY or tmID,
            R.Left + 116, R.Bottom - 30, 21, 21,
            Wnd, 0, hInstance, nil);
          SetProp(PickWnd, ID_DLGOBJ, Cardinal(_Self));
          SetWindowLong(PickWnd, GWL_ID, DLG_PICKID);
          OldPickWndProc := SetWindowLong(PickWnd, GWL_WNDPROC, Integer(@PickWndProc));

          EditWnd := CreateWindowEx(WS_EX_CLIENTEDGE,
            'EDIT', nil,
            WS_VISIBLE or WS_CHILD or ES_UPPERCASE or ES_AUTOHSCROLL,
            R.Left + 60, R.Bottom - 30, 55, 21,
            Wnd, 0, hInstance, nil);
          SetWindowLong(EditWnd, GWL_ID, DLG_EDITID);
          SetProp(EditWnd, ID_DLGOBJ, Cardinal(_Self));
          SendMessage(EditWnd, WM_SETFONT, hFont, 0);
          SendMessage(EditWnd, EM_SETLIMITTEXT, 6, 0);
          OldEditWndProc := SetWindowLong(EditWnd, GWL_WNDPROC, Integer(@EditWndProc));

          ColorDlg.OwnerWindow := Wnd;

          CBCount := SendMessage(CBWnd, CB_GETCOUNT, 0, 0);
          for I := 0 to CBCount - 1 do
          begin
            Colors.Add(Pointer(SendMessage(CBWnd, CB_GETITEMDATA, I, 0)));
          end;
          CBCurSel := Colors.IndexOf(Pointer(Color));
          if CBCurSel < 0 then
          begin
            SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
            Colors.Add(Pointer(Color));
            CBCurSel := Colors.Count - 1;
            SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
          end;
          SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
          TSmallPoint(I).x := DLG_COLORCB;
          TSmallPoint(I).y := CBN_SELCHANGE;
          SendMessage(Wnd, WM_COMMAND, I, CBWnd);

        end;

      WM_COMMAND:
        begin
          case TSmallPoint(wParam).X of
            DLG_PICKID:
              begin
                case TSmallPoint(wParam).Y of
                  STN_CLICKED:
                    begin
                      if GetWindowLong(PickWnd, GWL_USERDATA) = CN_APPLYCOLOR then
                        FR := True
                      else
                      begin
                        ColorDlg.Color := Color;
                        FR := ColorDlg.Execute;
                        if FR then Color := ColorDlg.Color;
                      end;
                      if FR then
                      begin
                        //-----
                        CBCurSel := Colors.IndexOf(Pointer(Color));
                        if CBCurSel < 0 then
                        begin
                          SendMessage(CBWnd, CB_ADDSTRING, 0, Integer(PChar('$' + Int2Hex(Color, 6))));
                          Colors.Add(Pointer(Color));
                          CBCurSel := Colors.Count - 1;
                          SendMessage(CBWnd, CB_SETITEMDATA, CBCurSel, Color);
                        end;
                        SendMessage(CBWnd, CB_SETCURSEL, CBCurSel, 0);
                        TSmallPoint(I).Y := CBN_SELCHANGE;
                        TSmallPoint(I).X := DLG_COLORCB;
                        SendMessage(Wnd, WM_COMMAND, I, CBWnd);
                        //-----
                      end;
                    end;  // STN_CLICKED
                end;      // case
              end;        // DLG_PICKID

            DLG_COLORCB:
              begin
                if TSmallPoint(wParam).Y = CBN_SELCHANGE then
                begin
                  CBCurSel := SendMessage(CBWnd, CB_GETCURSEL, 0, 0);
                  if CBCurSel >= 0 then
                  begin
                    Color := SendMessage(CBWnd, CB_GETITEMDATA, CBCurSel, 0);
                    SetWindowText(EditWnd, PChar(Int2Hex(Color, 6)));
                    SendMessage(PickWnd, WM_PAINT, 0, 0);
                  end;
                end;
              end;        // DLG_COLORCB

            DLG_EDITID:
              begin
                case TSmallPoint(wParam).Y of
                  EN_CHANGE:
                    begin
                      SetLength(st, 20);
                      GetWindowText(EditWnd, @st[1], 18);
                      Color := Hex2Int(st);
                      SendMessage(PickWnd, WM_PAINT, 0, 0);
                    end;
                end;
              end;        // DLG_EDITID

          end;            // case TSmallPoint( wParam ).X
        end;              // WM_COMMAND

    end;                  // case
  end;                    // with
end;

function TKOLFontProperty.DlgExecute: Boolean;
var
  TMPCF             : tagChooseFont;
  TMPLogFont        : tagLogFontA;
begin
  FillChar(TMPCF, SizeOf(TMPCF), 0);
  GetObject(Font.Handle, SizeOf(tagLOGFONT), @TMPLogFont);

  TMPCF.lStructSize := Sizeof(TMPCF);
  TMPCF.hWndOwner := hWndOwner;
  TMPCF.Flags := CF_EFFECTS or CF_BOTH or CF_ENABLEHOOK or CF_INITTOLOGFONTSTRUCT;
  TMPCF.lpfnHook := FontDialogHook;
  TMPCF.lpLogFont := @TMPLogFont;
  TMPCF.rgbColors := Color2RGB(Font.Color);
  TMPCF.lCustData := Integer(Self);
  Color := TMPCF.rgbColors;

  Result := ChooseFont(TMPCF);

  if Result then
  begin
    DeleteObject(Font.Handle);
    Font.Handle := CreateFontIndirectA(TMPLogFont);
    Font.Color := Color;
  end;
end;

function TKOLFontProperty.GetAttributes: TPropertyAttributes;
begin
  Result := inherited GetAttributes + [paDialog, paReadOnly];
end;

procedure TKOLFontProperty.Edit;
const
  Pitch2API         : array[TFontPitch] of Byte = (DEFAULT_PITCH, VARIABLE_PITCH, FIXED_PITCH);
var
  LF                : tagLOGFONT;
  F                 : TKOLFont;
  FS1               : TFontStyles;
begin
  //----------------
  hWndOwner := Application.Handle;
  Font := TFont.Create;
  Colors := NewList;
  ColorDlg := NewColorDialog(ccoFullOpen);
  //-----------------
  F := TKOLFont(GetOrdValue);

  FillChar(LF, SizeOf(tagLOGFONT), 0);
  LF.lfHeight := F.FontHeight;
  LF.lfWidth := F.FontWidth;
  LF.lfOrientation := F.FontOrientation;
  if fsBold in F.FontStyle then LF.lfWeight := 700;
  LF.lfItalic := Byte(fsItalic in F.FontStyle);
  LF.lfUnderline := Byte(fsUnderline in F.FontStyle);
  LF.lfStrikeOut := Byte(fsStrikeOut in F.FontStyle);
  LF.lfCharSet := F.FontCharset;
  LF.lfPitchAndFamily := Pitch2API[F.FontPitch];
  Move(F.FontName[1], LF.lfFaceName, Length(F.FontName));
  Font.Color := F.Color;

  Font.Handle := CreateFontIndirect(LF);

  if DlgExecute then
  begin
    FillChar(LF, SizeOf(tagLOGFONT), 0);
    GetObject(Font.Handle, SizeOf(tagLOGFONT), @LF);
    F.FontHeight := LF.lfHeight;
    F.FontWidth := LF.lfWidth;
    F.FontOrientation := LF.lfOrientation;

    FS1 := [];
    if Boolean(LF.lfItalic) then Include(FS1, fsItalic);
    if Boolean(LF.lfUnderline) then Include(FS1, fsUnderline);
    if Boolean(LF.lfStrikeOut) then Include(FS1, fsStrikeout);
    if LF.lfWeight > FW_NORMAL then Include(FS1, fsBold);
    F.FontStyle := FS1;

    F.FontCharset := LF.lfCharSet;
    case LF.lfPitchAndFamily of
      DEFAULT_PITCH: F.FontPitch := fpDefault;
      FIXED_PITCH: F.FontPitch := fpFixed;
      VARIABLE_PITCH: F.FontPitch := fpVariable;
    end;
    F.FontName := LF.lfFaceName;
    F.Color := Font.Color;

    SetOrdValue(Integer(F));
  end;

  //-----------------
  ColorDlg.Free;
  Colors.Free;
  Font.Free;
  //-----------------
end;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(TKOLFont), nil, '', TKOLFontProperty);
end;

end.