{************************************************}
{                                                }
{   Turbo Pascal for Windows                     }
{   Demo program                                 }
{   Copyright (c) 1991 by Borland International  }
{   Changes for demonstration of ChooseColor     }
{   and ChooseFont are made by Martin H. Speiser }
{                                                }
{************************************************}

{ "ColDem" Windows application written in Turbo Pascal }

program ColDem;

{$R COLDEM}

uses WinTypes, WinProcs, Strings, Win31, CommDlg;

const
  AppName = 'ColDem';

const
  idm_Color = 100;
  idm_Font  = 102;
  idm_About = 101;

  idd_StaticControl = 1040;
  idd_EditControl   = 1041;

function About(Dialog: HWnd; Message, WParam: Word;
  LParam: Longint): Bool; export;
begin
  About := True;
  case Message of
    wm_InitDialog:
      Exit;
    wm_Command:
      if (WParam = id_Ok) or (WParam = id_Cancel) then
      begin
        EndDialog(Dialog, 1);
        Exit;
      end;
  end;
  About := False;
end;

function ColorHookProc(HDialog: HWnd; Message, WParam: Word;
  LParam: Longint): Bool; export;
begin
  ColorHookProc := True;
  case Message of
    wm_InitDialog : begin
                      SetWindowText(GetDlgItem(HDialog,idd_EditControl),PChar(PChooseColor(LParam)^.lCustData));
                      SendMessage(GetDlgItem(HDialog,idd_EditControl),em_LimitText,30,0);
                      {SetFocus(GetDlgItem(HDialog,idd_EditControl));}
                      exit;
                    end
  end;
  ColorHookProc := False;
end;

function WindowProc(Window: HWnd; Message, WParam: Word;
  LParam: Longint): Longint; export;
var AboutProc : TFarProc;
    hDisplay  : HDC;
    ps        : TPaintStruct;
    rc        : TRect;
    cc        : TChooseColor;
    cf        : TChooseFont;
    lf        : TLogFont;
    CustCol   : array[0..15] of longint;
    HookProc  : TFarProc;
    szText    : array[0..30] of char;
    lpszText  : PChar;
begin
  WindowProc := 0;
  case Message of
    wm_Command : case WParam of
                   idm_Color : begin
                                 lpszText := @szText;
                                 StrPCopy(lpszText,'Hello World');
                                 HookProc := MakeProcInstance(@ColorHookProc,HInstance);
                                 cc.lStructSize   := SizeOf(cc);
                                 { Size of Record, for possible extensions in the future }
                                 cc.hWndOwner     := Window;
                                 { Handle of Parent                                      }
                                 cc.hInstance     := HInstance;
                                 { Instance handle, only necessary for template          }
                                 cc.rgbResult     := RGB(255,255,255);
                                 { Default color at input, choosen color on exit         }
                                 cc.lpCustColors  := @CustCol;
                                 { Definition of custom colors at exit                   }
                                 cc.Flags         := cc_RGBInit or
                                                     cc_EnableHook or
                                                     cc_EnableTemplate;
                                 { see COMMDLG.PAS for possible values }
                                 cc.lCustData     := Longint(lpszText);
                                 { Pointer to custom data for hook function              }
                                 cc.lpfnHook      := HookProc;
                                 { Pointer to hook function                              }
                                 cc.lpTemplateName := 'ChooseColor';
                                 { Name of Template                                      }
                                 ChooseColor(cc);
                                 FreeProcInstance(HookProc);
                               end;
                   idm_Font  : begin
                                 cf.lStructSize := SizeOf(cf);
                                 { Size of Record, purpose see above }
                                 cf.hwndOwner   := Window;
                                 cf.lpLogFont   := @lf;
                                 { Handle of parent window }
                                 cf.Flags       := cf_Effects or
                                                   cf_ScreenFonts or
                                                   cf_TTOnly or
                                                   cf_EnableTemplate;
                                 { see COMMDLG.PAS for possible values }
                                 cf.rgbColors   := RGB(0,0,0);
                                 { Default color at input, choosen color on exit         }
                                 cf.lpTemplateName := 'FontDialog';
                                 cf.hInstance   := HInstance;
                                 cf.nFontType   := TrueType_Fonttype;
                                 ChooseFont(cf);
                               end;
                   idm_About : begin
                                 AboutProc := MakeProcInstance(@About, HInstance);
                                 DialogBox(HInstance, 'AboutBox', Window, AboutProc);
                                 FreeProcInstance(AboutProc);
                                 Exit;
                               end;
                 end;
    wm_Destroy : begin
                   PostQuitMessage(0);
                   Exit;
                 end;
  end;
  WindowProc := DefWindowProc(Window, Message, WParam, LParam);
end;

procedure WinMain;
var
  Window: HWnd;
  Message: TMsg;
const
  WindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @WindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: AppName;
    lpszClassName: AppName);
begin
  if HPrevInst = 0 then
  begin
    WindowClass.hInstance := HInstance;
    WindowClass.hIcon := LoadIcon(0, idi_Application);
    WindowClass.hCursor := LoadCursor(0, idc_Arrow);
    WindowClass.hbrBackground := GetStockObject(white_Brush);
    if not RegisterClass(WindowClass) then Halt(255);
  end;
  Window := CreateWindow(
    AppName,
    'Turbo Pascal ChooseColor Demo',
    ws_OverlappedWindow,
    cw_UseDefault,
    cw_UseDefault,
    cw_UseDefault,
    cw_UseDefault,
    0,
    0,
    HInstance,
    nil);
  ShowWindow(Window, CmdShow);
  UpdateWindow(Window);
  while GetMessage(Message, 0, 0, 0) do
  begin
    TranslateMessage(Message);
    DispatchMessage(Message);
  end;
  Halt(Message.wParam);
end;

begin
  WinMain;
end.