home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / pcmagazi / 1992 / 20 / ln1120 / utest4.pas < prev    next >
Pascal/Delphi Source File  |  1992-08-02  |  4KB  |  172 lines
  1. {
  2. Title: UTest4.pas
  3. Caption:  Here we have the TChooseFont object, which emulates the 'Borland look' on top of the Font common dialog.
  4. }
  5.  
  6.  
  7. unit utest4;
  8.  
  9. interface
  10.  
  11. {$R utest4}
  12.    
  13. uses
  14.   wintypes, winprocs, wobjects, strings, win31, COMMDLG,BWCC;
  15.  
  16.  
  17. type
  18.    PChooseFontDlg = ^TChooseFontDlg;
  19.    TChooseFontDlg = object(TDialog)
  20.      CF : TChooseFont;
  21.      GrayBrush : hBrush;
  22.          constructor Init(AParent  : PWindowsObject;
  23.                       AFlags   : Longint;
  24.                       ALogFont : PLogFont);
  25.      destructor  Done; virtual;
  26.      function    Execute : integer; virtual;
  27.      procedure   OK(var Msg : TMessage);
  28.                     virtual id_First+id_OK;
  29.      procedure   Cancel(var Msg : TMessage);
  30.                     virtual id_first+id_Cancel;
  31.      procedure   WMCtlColor(var Msg : TMessage);
  32.                     virtual wm_first+wm_CtlColor;
  33.    end;
  34.  
  35. const
  36.   rgbLightGray  = $C0C0C0;
  37.   idFontDisplay = 1092;
  38.  
  39. implementation
  40.  
  41. type
  42.    PSeeThrough = ^TSeeThrough;
  43.    TSeeThrough = object(TWindow)
  44.      procedure SetupWindow; virtual;
  45.      procedure wmPaint(var Msg: TMessage);
  46.                   virtual wm_First + wm_Paint;
  47.      procedure wmEraseBkgnd(var Msg: TMessage);
  48.                   virtual wm_First + wm_EraseBkgnd;
  49.    end;
  50.  
  51. { TChooseFontDlg Methods }
  52. constructor TChooseFontDlg.Init(AParent  : PWindowsObject;
  53.                                 AFlags   : Longint;
  54.                                 ALogFont : PLogFont);
  55. var
  56.   Dummy: PWindowsObject;
  57. begin
  58.      TDialog.Init(AParent,'CFM_BWCC');
  59.    FillChar(CF,Sizeof(CF),0);
  60.    GrayBrush := CreateSolidBrush(rgbLightGray);
  61.    with CF do
  62.    begin
  63.      lStructSize := SizeOf(CF);
  64.      if AParent <> nil then
  65.         hwndOwner := AParent^.hWindow;
  66.      lpLogFont    := ALogFont;
  67.      Flags        := AFlags or CF_SCREENFONTS or
  68.                      CF_ENABLEHOOK or CF_ENABLETEMPLATE;
  69.      @CF.lpfnHook := Instance;
  70.      hInstance    := System.hInstance;
  71.      lpTemplateName := 'CFM_BWCC';
  72.    end;
  73.    Dummy := New(PSeeThrough, InitResource(@Self, idFontDisplay));
  74. end;
  75.  
  76.  
  77. destructor TChooseFontDlg.Done;
  78. begin
  79.   DeleteObject(GrayBrush);
  80.   TDialog.Done;
  81. end;
  82.  
  83.  
  84. function    TChooseFontDlg.Execute : Integer;
  85. { Basically, this is the code from TDialog.Execute with the call to
  86.   DialogBoxParam changed to a call to the CommonDialogExec method }
  87. var
  88.   CDError : Longint;
  89.   OldKbHandler: PWindowsObject;
  90. begin
  91.   if Status = 0 then
  92.   begin
  93.     DisableAutoCreate;
  94.     EnableKBHandler;
  95.     IsModal := True;
  96.     OldKbHandler := Application^.KBHandlerWnd;
  97.     if ChooseFont(CF) then
  98.       Execute := id_ok
  99.     else
  100.     begin
  101.       CDError := CommDlgExtendedError;
  102.       if CDError = 0 then
  103.         Execute := id_Cancel
  104.       else
  105.       begin
  106.         Status := -CdError;
  107.         Execute := Status;
  108.       end;
  109.     end;
  110.     Application^.KBHandlerWnd := OldKbHandler;
  111.     HWindow := 0;
  112.   end
  113.   else Execute := Status;
  114. end;
  115.  
  116. procedure   TChooseFontDlg.OK(var Msg : TMessage);
  117. begin
  118.   if CanClose then
  119.      Msg.Result := 0
  120.   else
  121.      Msg.Result := 1;
  122. end;
  123.  
  124. procedure   TChooseFontDlg.Cancel(var Msg : TMessage);
  125. begin
  126.   Msg.Result := 0
  127. end;
  128.  
  129.  
  130. Procedure TChooseFontDlg.WMCTLCOLOR;
  131. { Emulate the BWCC look by painting the background with BWCC's
  132.   "chiseled steel" brush.}
  133. begin
  134.   SetBkColor(hdc(Msg.wParam),rgbLightGray);
  135.   if (Msg.lParamHi = CtlColor_DLG) and (Msg.lParamLo = hWindow) then
  136.     Msg.Result := BWCCGetPattern
  137.   else
  138.     Msg.Result := GrayBrush;
  139. end;
  140.  
  141.  
  142.  
  143. { TSeeThrough methods.  This object is used to 'cut a hole' in the
  144.   BWCC facade, to allow areas that are painted by the CommDlg dialog
  145.   function to show through.  The ChooseFont dialog's sample font display
  146.   is drawn by the CommDlg dialog function, and would be painted over
  147.   by a normal BWCC dialog. } 
  148.  
  149. procedure TSeeThrough.SetupWindow;
  150. begin
  151.   TWindow.SetupWindow;
  152.   ShowWindow(HWindow, sw_Show); 
  153. end;
  154.  
  155. procedure TSeeThrough.wmPaint(var Msg: TMessage);
  156. var PS: TPaintStruct;
  157. begin
  158.   Msg.Result := 1;          { Tell Windows we've handled this message }
  159.   BeginPaint(HWindow, PS);  { then fake a paint sequence.  This will  }
  160.   EndPaint(HWindow, PS);    { provide the illusion of transparency.   }
  161. end;
  162.  
  163. procedure TSeeThrough.wmEraseBkgnd(var Msg: TMessage);
  164. var R: TRect;
  165. begin
  166.   Msg.Result := 1;   { Prevent Windows from performing default erasures }
  167. end;
  168.  
  169.  
  170. end.
  171.  
  172.