home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 August / CICA.cdr / unzipped / programr / tp / coldem / coldem.pas next >
Encoding:
Pascal/Delphi Source File  |  1992-06-29  |  6.8 KB  |  189 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {   Changes for demonstration of ChooseColor     }
  7. {   and ChooseFont are made by Martin H. Speiser }
  8. {                                                }
  9. {************************************************}
  10.  
  11. { "ColDem" Windows application written in Turbo Pascal }
  12.  
  13. program ColDem;
  14.  
  15. {$R COLDEM}
  16.  
  17. uses WinTypes, WinProcs, Strings, Win31, CommDlg;
  18.  
  19. const
  20.   AppName = 'ColDem';
  21.  
  22. const
  23.   idm_Color = 100;
  24.   idm_Font  = 102;
  25.   idm_About = 101;
  26.  
  27.   idd_StaticControl = 1040;
  28.   idd_EditControl   = 1041;
  29.  
  30. function About(Dialog: HWnd; Message, WParam: Word;
  31.   LParam: Longint): Bool; export;
  32. begin
  33.   About := True;
  34.   case Message of
  35.     wm_InitDialog:
  36.       Exit;
  37.     wm_Command:
  38.       if (WParam = id_Ok) or (WParam = id_Cancel) then
  39.       begin
  40.         EndDialog(Dialog, 1);
  41.         Exit;
  42.       end;
  43.   end;
  44.   About := False;
  45. end;
  46.  
  47. function ColorHookProc(HDialog: HWnd; Message, WParam: Word;
  48.   LParam: Longint): Bool; export;
  49. begin
  50.   ColorHookProc := True;
  51.   case Message of
  52.     wm_InitDialog : begin
  53.                       SetWindowText(GetDlgItem(HDialog,idd_EditControl),PChar(PChooseColor(LParam)^.lCustData));
  54.                       SendMessage(GetDlgItem(HDialog,idd_EditControl),em_LimitText,30,0);
  55.                       {SetFocus(GetDlgItem(HDialog,idd_EditControl));}
  56.                       exit;
  57.                     end
  58.   end;
  59.   ColorHookProc := False;
  60. end;
  61.  
  62. function WindowProc(Window: HWnd; Message, WParam: Word;
  63.   LParam: Longint): Longint; export;
  64. var AboutProc : TFarProc;
  65.     hDisplay  : HDC;
  66.     ps        : TPaintStruct;
  67.     rc        : TRect;
  68.     cc        : TChooseColor;
  69.     cf        : TChooseFont;
  70.     lf        : TLogFont;
  71.     CustCol   : array[0..15] of longint;
  72.     HookProc  : TFarProc;
  73.     szText    : array[0..30] of char;
  74.     lpszText  : PChar;
  75. begin
  76.   WindowProc := 0;
  77.   case Message of
  78.     wm_Command : case WParam of
  79.                    idm_Color : begin
  80.                                  lpszText := @szText;
  81.                                  StrPCopy(lpszText,'Hello World');
  82.                                  HookProc := MakeProcInstance(@ColorHookProc,HInstance);
  83.                                  cc.lStructSize   := SizeOf(cc);
  84.                                  { Size of Record, for possible extensions in the future }
  85.                                  cc.hWndOwner     := Window;
  86.                                  { Handle of Parent                                      }
  87.                                  cc.hInstance     := HInstance;
  88.                                  { Instance handle, only necessary for template          }
  89.                                  cc.rgbResult     := RGB(255,255,255);
  90.                                  { Default color at input, choosen color on exit         }
  91.                                  cc.lpCustColors  := @CustCol;
  92.                                  { Definition of custom colors at exit                   }
  93.                                  cc.Flags         := cc_RGBInit or
  94.                                                      cc_EnableHook or
  95.                                                      cc_EnableTemplate;
  96.                                  { see COMMDLG.PAS for possible values }
  97.                                  cc.lCustData     := Longint(lpszText);
  98.                                  { Pointer to custom data for hook function              }
  99.                                  cc.lpfnHook      := HookProc;
  100.                                  { Pointer to hook function                              }
  101.                                  cc.lpTemplateName := 'ChooseColor';
  102.                                  { Name of Template                                      }
  103.                                  ChooseColor(cc);
  104.                                  FreeProcInstance(HookProc);
  105.                                end;
  106.                    idm_Font  : begin
  107.                                  cf.lStructSize := SizeOf(cf);
  108.                                  { Size of Record, purpose see above }
  109.                                  cf.hwndOwner   := Window;
  110.                                  cf.lpLogFont   := @lf;
  111.                                  { Handle of parent window }
  112.                                  cf.Flags       := cf_Effects or
  113.                                                    cf_ScreenFonts or
  114.                                                    cf_TTOnly or
  115.                                                    cf_EnableTemplate;
  116.                                  { see COMMDLG.PAS for possible values }
  117.                                  cf.rgbColors   := RGB(0,0,0);
  118.                                  { Default color at input, choosen color on exit         }
  119.                                  cf.lpTemplateName := 'FontDialog';
  120.                                  cf.hInstance   := HInstance;
  121.                                  cf.nFontType   := TrueType_Fonttype;
  122.                                  ChooseFont(cf);
  123.                                end;
  124.                    idm_About : begin
  125.                                  AboutProc := MakeProcInstance(@About, HInstance);
  126.                                  DialogBox(HInstance, 'AboutBox', Window, AboutProc);
  127.                                  FreeProcInstance(AboutProc);
  128.                                  Exit;
  129.                                end;
  130.                  end;
  131.     wm_Destroy : begin
  132.                    PostQuitMessage(0);
  133.                    Exit;
  134.                  end;
  135.   end;
  136.   WindowProc := DefWindowProc(Window, Message, WParam, LParam);
  137. end;
  138.  
  139. procedure WinMain;
  140. var
  141.   Window: HWnd;
  142.   Message: TMsg;
  143. const
  144.   WindowClass: TWndClass = (
  145.     style: 0;
  146.     lpfnWndProc: @WindowProc;
  147.     cbClsExtra: 0;
  148.     cbWndExtra: 0;
  149.     hInstance: 0;
  150.     hIcon: 0;
  151.     hCursor: 0;
  152.     hbrBackground: 0;
  153.     lpszMenuName: AppName;
  154.     lpszClassName: AppName);
  155. begin
  156.   if HPrevInst = 0 then
  157.   begin
  158.     WindowClass.hInstance := HInstance;
  159.     WindowClass.hIcon := LoadIcon(0, idi_Application);
  160.     WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  161.     WindowClass.hbrBackground := GetStockObject(white_Brush);
  162.     if not RegisterClass(WindowClass) then Halt(255);
  163.   end;
  164.   Window := CreateWindow(
  165.     AppName,
  166.     'Turbo Pascal ChooseColor Demo',
  167.     ws_OverlappedWindow,
  168.     cw_UseDefault,
  169.     cw_UseDefault,
  170.     cw_UseDefault,
  171.     cw_UseDefault,
  172.     0,
  173.     0,
  174.     HInstance,
  175.     nil);
  176.   ShowWindow(Window, CmdShow);
  177.   UpdateWindow(Window);
  178.   while GetMessage(Message, 0, 0, 0) do
  179.   begin
  180.     TranslateMessage(Message);
  181.     DispatchMessage(Message);
  182.   end;
  183.   Halt(Message.wParam);
  184. end;
  185.  
  186. begin
  187.   WinMain;
  188. end.
  189.