home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d123456 / DFS.ZIP / GradForm.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-27  |  72KB  |  1,961 lines
  1. {$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }
  2.  
  3. {------------------------------------------------------------------------------}
  4. { TdfsGradientForm v2.03                                                       }
  5. { A form to provide gradient filled caption bars ala Microsoft Office.         }
  6. { You will notice that some of the initial comment characters are followed by  }
  7. { a colon, and those sometimes contains some odd looking things that resemble  }
  8. { HTML codes.  These comments are used by the Time2Help application that I     }
  9. { used to build the help file.                                                 }
  10. {                                                                              }
  11. { Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
  12. {                                                                              }
  13. { Copyright:                                                                   }
  14. { All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
  15. { Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
  16. { property of the author.                                                      }
  17. {                                                                              }
  18. { Distribution Rights:                                                         }
  19. { You are granted a non-exlusive, royalty-free right to produce and distribute }
  20. { compiled binary files (executables, DLLs, etc.) that are built with any of   }
  21. { the DFS source code unless specifically stated otherwise.                    }
  22. { You are further granted permission to redistribute any of the DFS source     }
  23. { code in source code form, provided that the original archive as found on the }
  24. { DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
  25. { example, if you create a descendant of TDFSColorButton, you must include in  }
  26. { the distribution package the colorbtn.zip file in the exact form that you    }
  27. { downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
  28. {                                                                              }
  29. { Restrictions:                                                                }
  30. { Without the express written consent of the author, you may not:              }
  31. {   * Distribute modified versions of any DFS source code by itself. You must  }
  32. {     include the original archive as you found it at the DFS site.            }
  33. {   * Sell or lease any portion of DFS source code. You are, of course, free   }
  34. {     to sell any of your own original code that works with, enhances, etc.    }
  35. {     DFS source code.                                                         }
  36. {   * Distribute DFS source code for profit.                                   }
  37. {                                                                              }
  38. { Warranty:                                                                    }
  39. { There is absolutely no warranty of any kind whatsoever with any of the DFS   }
  40. { source code (hereafter "software"). The software is provided to you "AS-IS", }
  41. { and all risks and losses associated with it's use are assumed by you. In no  }
  42. { event shall the author of the softare, Bradley D. Stowers, be held           }
  43. { accountable for any damages or losses that may occur from use or misuse of   }
  44. { the software.                                                                }
  45. {                                                                              }
  46. { Support:                                                                     }
  47. { Support is provided via the DFS Support Forum, which is a web-based message  }
  48. { system.  You can find it at http://www.delphifreestuff.com/discus/           }
  49. { All DFS source code is provided free of charge. As such, I can not guarantee }
  50. { any support whatsoever. While I do try to answer all questions that I        }
  51. { receive, and address all problems that are reported to me, you must          }
  52. { understand that I simply can not guarantee that this will always be so.      }
  53. {                                                                              }
  54. { Clarifications:                                                              }
  55. { If you need any further information, please feel free to contact me directly.}
  56. { This agreement can be found online at my site in the "Miscellaneous" section.}
  57. {------------------------------------------------------------------------------}
  58. { The lateset version of my components are always available on the web at:     }
  59. {   http://www.delphifreestuff.com/                                            }
  60. { See GradForm.txt for notes, known issues, and revision history.              }
  61. {------------------------------------------------------------------------------}
  62. { Date last modified:  June 27, 2001                                           }
  63. {------------------------------------------------------------------------------}
  64.  
  65.  
  66. {: This unit provides the TdfsGradientForm class, and all supporting elements. }
  67. unit GradForm;
  68.  
  69. {$IFNDEF DFS_WIN32}
  70.   Error!  This unit is only available for Win32.
  71. {$ENDIF}
  72.  
  73. interface
  74.  
  75. uses
  76.   {$IFDEF DFS_COMPILER_6_UP}
  77.   RTLConsts,
  78.   {$ELSE}
  79.   Consts,
  80.   {$ENDIF}
  81.   Windows, Messages, SysUtils, Forms, Classes, Graphics, Controls, Dialogs;
  82.  
  83. const
  84.   { This shuts up C++Builder 3 about the redefiniton being different. There
  85.     seems to be no equivalent in C1.  Sorry. }
  86.   {$IFDEF DFS_CPPB_3_UP}
  87.   {$EXTERNALSYM DFS_COMPONENT_VERSION}
  88.   {$ENDIF}
  89.   DFS_COMPONENT_VERSION             = 'TdfsGradientForm v2.03';
  90.  
  91.   {: The minimum number of colors that can be assigned to the
  92.      <See Property=TdfsGradientForm.GradientColors Text=GradientColors> property.
  93.      Any less than 8 colors doesn't look much like a gradient.
  94.      <Related A=MAX_GRADIENT_COLORS;DEF_GRADIENT_COLORS>
  95.   }
  96.   MIN_GRADIENT_COLORS               = 8;
  97.   {: The maximum number of colors that can be assigned to the
  98.      <See Property=TdfsGradientForm.GradientColors Text=GradientColors> property.
  99.      Any more than 512 colors is not noticeable, and just slows the painting
  100.      down. <Related A=MIN_GRADIENT_COLORS;DEF_GRADIENT_COLORS> }
  101.   MAX_GRADIENT_COLORS               = 512;
  102.   {: The default number of colors for the
  103.      <See Property=TdfsGradientForm.GradientColors Text=GradientColors> property.
  104.      This is a good compromise between speed and appearance.
  105.      <Related A=MAX_GRADIENT_COLORS;MIN_GRADIENT_COLORS>}
  106.   DEF_GRADIENT_COLORS               = 64;
  107.   DEF_CAPTION_TEXT_COLOR            = clWhite;
  108.   DEF_INACTIVE_CAPTION_TEXT_COLOR   = clWhite;
  109.   DEF_GRADIENT_START_COLOR          = clBlack;
  110.   DEF_GRADIENT_STOP_COLOR           = clActiveCaption;
  111.   DEF_GRADIENT_INACTIVE_START_COLOR = clBlack;
  112.   DEF_GRADIENT_INACTIVE_STOP_COLOR  = clInactiveCaption;
  113.   DEF_USE_WIN98_GRADIENT            = FALSE;
  114.   DEF_USE_DITHERING                 = TRUE;
  115.  
  116. type
  117.   {: For some reason, you can not pass HWND and HDC type parameters from
  118.      C++Builder source code to a Delphi component.  For some reason, C++B wants
  119.      to treat these parameters as "void *" (pointer) types, and you will get
  120.      unresolved external linker errors from Builder if you have methods that
  121.      take HWND and/or HDC parameters in other than the private section.
  122.  
  123.      I have delcared this type so that it makes the code cleaner below. }
  124.  
  125.   {$IFDEF DFS_CPPB}
  126.   DFS_HDC = pointer;
  127.   {$ELSE}
  128.   DFS_HDC = HDC;
  129.   {$ENDIF}
  130.   
  131.   {: This enumerated type is used by the
  132.      <See Property=TdfsGradientForm.PaintGradient Text=PaintGradient> property to
  133.      indicate when the caption should be painted as a gradient.<BR>
  134.      <UL>
  135.      <LI>gfpAlways <TAB> The gradient should always be drawn.
  136.      <LI>gfpActive <TAB> Only draw the gradient when the form is active.
  137.      <LI>gfpNever  <TAB> Never draw the gradient.
  138.      </UL>
  139.      <Related A=PaintGradient>}
  140.   TGFPaintWhen = (gfpAlways, gfpActive, gfpNever);
  141.   TGFLogoAlign = (laLeft, laRight);
  142.  
  143. const
  144.   DEF_PAINT_GRADIENT = gfpAlways;
  145.  
  146. type
  147.   {: Describes the parameters used by an
  148.      <See Event=TdfsGradientForm.OnCaptionPaint Text=OnCaptionPaint> event handler.
  149.      <BR><BR><B>Sender</B> is the TdfsGradientForm that is being painted.<BR><BR>
  150.      <B>Canvas</B> is the drawing surface that is being painted.  Anything you
  151.      want to appear on the caption must be drawn on this canvas.  This canvas is
  152.      not the actual caption canvas, it is a memory bitmap (non-visible).  This
  153.      prevents flicker as many things are being drawn since the actual visible
  154.      drawing only happens when the entire drawing operation is complete.<BR><BR>
  155.      <B>R</B> is a rectangle that describes the area in which you can draw.
  156.      When the event is first fired, this rectangle will be the entire caption
  157.      less the system icon on the left (if any) and the caption buttons on the
  158.      right (if any).  After performing your drawing operations, this value
  159.      should be modified so that the area you have painted is subtracted out.
  160.      This prevents the gradient from painting over what you have just done.
  161.      <Related A=OnCaptionPaint>}
  162.   TGFOnCaptionPaint = procedure(Sender: TObject; Canvas: TCanvas;
  163.      var R: TRect) of object;
  164.  
  165. //CE_Desc_Begin(TdfsGradientForm)
  166. {TdfsGradientForm is a descendant of the TForm class that paints it's caption
  167. bar in a gradient fill pattern, like the Microsoft Office applications.
  168. By default, it starts with black and moves gradually to the system defined
  169. caption color, although you can override these values.  Also provided is
  170. an event to allow you to add your own custom painting on the caption bar. }
  171. //CE_Desc_End
  172.   TdfsGradientForm = class(TForm)
  173.   private
  174.     // Internal variables
  175.     Colors: array[0..1, 0..MAX_GRADIENT_COLORS-1] of TColorRef;
  176. //**    CaptionFontHandle: HFONT;
  177.     FGradDefClientProc: TFarProc;
  178.     FGradClientInstance: TFarProc;
  179.     // Property variables
  180.     FCaptionTextColor: TColor;
  181.     FInactiveCaptionTextColor: TColor;
  182.     FGradientStartColor: TColor;
  183.     FGradientStopColor: TColor;
  184.     FGradientInactiveStartColor: TColor;
  185.     FGradientInactiveStopColor: TColor;
  186.     FGradientColors: integer;
  187.     FPaintGradient: TGFPaintWhen;
  188.     FCaptionText: string;
  189.     FOnCaptionPaint: TGFOnCaptionPaint;
  190.     FUsingDefaultGradientStopColor: boolean;
  191.     FUsingDefaultGradientInactiveStopColor: boolean;
  192.     FUseWin98Gradient: boolean;
  193.     FRunningOnWin98: boolean;
  194.     FChangingActivationState: boolean;
  195.     FPaint16Color: boolean;
  196.     FSystemIs16Color: boolean;
  197.     FCaptionFont: TFont;
  198.     FUseSystemCaptionFont: boolean;
  199.     FCreating: boolean;
  200.     FUseDithering: boolean;
  201.     FLogo: TBitmap;
  202.     FLogoAlign: TGFLogoAlign;
  203.     FLogoLayered: Boolean;
  204.     FInactiveLogo: TBitmap;
  205.  
  206.     // Internal methods
  207.     function IsActiveWindow: boolean;
  208. //**    procedure CreateCaptionFontHandle;
  209.     // Window message handlers
  210.     procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
  211.     procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;
  212.     procedure WMSysColorChange(var Msg: TWMSysColorChange);
  213.        message WM_SYSCOLORCHANGE;
  214.     procedure WMSize(var Msg: TWMSize); message WM_SIZE;
  215.     procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
  216.     procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
  217.     procedure WMGetText(var Msg: TWMGetText); message WM_GETTEXT;
  218.     procedure WMGetTextLength(var Msg: TWMGetTextLength);
  219.        message WM_GETTEXTLENGTH;
  220.     procedure WMSettingChange(var Msg: TMessage); message WM_SETTINGCHANGE;
  221.     procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown);
  222.        message WM_NCLBUTTONDOWN;
  223.     procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
  224.     procedure WMEnterIdle(var Msg: TWMEnterIdle); message WM_ENTERIDLE;
  225.     procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);
  226.        message WM_WINDOWPOSCHANGING;
  227.     // MDI Client Window Procedure
  228.     procedure GradClientWndProc(var Message: TMessage);
  229.     function GetInhibitGradient: boolean;
  230.     procedure SetCaptionFont(const Value: TFont);
  231.     // Misc
  232.     function GetSysCaptionLogFont: TLogFont;
  233.     procedure SetUseSystemCaptionFont(const Value: boolean);
  234.   protected
  235.     // Virtual methods useful for descandants
  236.     function GetCaptionRect: TRect; virtual;
  237.     procedure InvalidateCaption;
  238.     function DrawCaption(FormDC: DFS_HDC; Active: boolean): TRect; virtual;
  239.     procedure PaintMenuIcon(DC: DFS_HDC; var R: TRect; Active: boolean); virtual;
  240.     procedure FillRectSolid(DC: DFS_HDC; const R: TRect; Active: boolean;
  241.       ActiveColor, InactiveColor : TColor); virtual;
  242.     procedure FillRectGradient(DC: DFS_HDC; const R: TRect;
  243.        Dithered, Active: boolean); virtual;
  244.     procedure PaintCaptionText(DC: DFS_HDC; R: TRect; Active: boolean); virtual;
  245.     procedure PaintCaptionButtons(DC: DFS_HDC; var Rect: TRect); virtual;
  246.     procedure CalculateColors; virtual;
  247.     // Overriden methods
  248.     procedure Loaded; override;
  249.     procedure CreateWnd; override;
  250.     procedure DestroyWnd; override;
  251.     procedure Activate; override;
  252.     procedure Deactivate; override;
  253.     procedure DoShow; override;
  254.     // Property methods
  255.     procedure SetCaptionTextColor(Color: TColor);
  256.     procedure SetInactiveCaptionTextColor(Color: TColor);
  257.     procedure SetGradientStartColor(Color : TColor);
  258.     procedure SetGradientStopColor(Color : TColor);
  259.     procedure SetGradientInactiveStartColor(Color : TColor);
  260.     procedure SetGradientInactiveStopColor(Color : TColor);
  261.     procedure SetGradientColors(Val: integer);
  262.     procedure SetPaintGradient(Val: TGFPaintWhen);
  263.     procedure SetCaptionText(const Val: string);
  264.     procedure SetUseWin98Gradient(Val: boolean);
  265.     procedure SetUseDithering(Val: boolean);
  266.     procedure SetPaint16Color(const Value: boolean);
  267.     procedure SetLogo(const Value: TBitmap);
  268.     procedure SetLogoAlign(const Value: TGFLogoAlign);
  269.     procedure SetLogoLayered(const Value: Boolean);
  270.     procedure SetInactiveLogo(const Value: TBitmap);
  271.     function GetVersion: string;
  272.     procedure SetVersion(const Val: string);
  273.     // Property storage qualifing methods
  274.     function StoreGradientStopColor: boolean;
  275.     function StoreGradientInactiveStopColor: boolean;
  276.     // Utility methods
  277.     function Win98Check: boolean; virtual;
  278.     procedure UpdateCaptionFont; virtual;
  279.   public
  280.     function GetSystemColorBitDepth: integer;
  281.     { This procedure is used to paint the caption gradient. }
  282.     procedure Draw(Active: boolean); virtual;
  283.     // Overridden methods
  284.     { Create creates and initializes an instance of TdfsGradientForm. }
  285.     constructor Create(AOwner: TComponent); override;
  286.     { Destroy destroys an instance of TdfsGradientForm. }
  287.     destructor Destroy; override;
  288.  
  289.     property InhibitGradient: boolean
  290.        read GetInhibitGradient;
  291.     property Paint16Color: boolean
  292.        read FPaint16Color
  293.        write SetPaint16Color;
  294.     property SystemIs16Color: boolean
  295.        read FSystemIs16Color;
  296.   published
  297.     // Properties
  298.     property Version: string
  299.        read GetVersion
  300.        write SetVersion
  301.        stored FALSE;
  302.     {: Caption specifies a text string that appears in the caption bar. }
  303.     property Caption: string
  304.        read FCaptionText
  305.        write SetCaptionText
  306.        stored TRUE;
  307.     property CaptionFont: TFont
  308.        read FCaptionFont
  309.        write SetCaptionFont;
  310.     property UseSystemCaptionFont: boolean
  311.        read FUseSystemCaptionFont
  312.        write SetUseSystemCaptionFont;
  313.     {: Determines the number of colors used to paint the gradient pattern.  The
  314.        individual colors are determined by fading the start color into the stop
  315.        color.  The number of times this is done is controled by this property.
  316.        The higher the number of colors, the smoother the gradient will appear.
  317.        However, the more colors that are used, the more complex the painting
  318.        will be.
  319.        <Related A=MAX_GRADIENT_COLORS;MIN_GRADIENT_COLORS;DEF_GRADIENT_COLORS> }
  320.     property GradientColors: integer
  321.        read FGradientColors
  322.        write SetGradientColors
  323.        default DEF_GRADIENT_COLORS;
  324.     {: CaptionTextColor is the color that should be used for the text draw in
  325.        the caption bar.  You may have to adjust this color if you change the
  326.        <See Property=TdfsGradientForm.GradientStartColor Text=GradientStartColor>
  327.        to something other than the default of clBlack.
  328.        <Related A=GradientStartColor;GradientStopColor;Caption>}
  329.     property CaptionTextColor: TColor
  330.        read FCaptionTextColor
  331.        write SetCaptionTextColor
  332.        default DEF_CAPTION_TEXT_COLOR;
  333.     property InactiveCaptionTextColor: TColor
  334.        read FInactiveCaptionTextColor
  335.        write SetInactiveCaptionTextColor
  336.        default DEF_INACTIVE_CAPTION_TEXT_COLOR;
  337.     {: The leftmost gradient color.  This is the color that is used at the
  338.        beginning of the caption (the far left), and is gradually faded into the
  339.        <See Property=TdfsGradientForm.GradientStopColor Text=GradientStopColor>.
  340.        <Related A=GradientStopColor;GradientColors> }
  341.     property GradientStartColor: TColor
  342.        read FGradientStartColor
  343.        write SetGradientStartColor
  344.        default DEF_GRADIENT_START_COLOR;
  345.     {: The rightmost gradient color. This is the color that is used at the
  346.        end of the caption (the far right), and is gradually faded from the
  347.        <See Property=TdfsGradientForm.GradientStartColor Text=GradientStartColor>.
  348.        <Related A=GradientStartColor;GradientColors> }
  349.     property GradientStopColor: TColor
  350.        read FGradientStopColor
  351.        write SetGradientStopColor
  352.        stored StoreGradientStopColor
  353.        default DEF_GRADIENT_STOP_COLOR;
  354.     property GradientInactiveStartColor: TColor
  355.        read FGradientInactiveStartColor
  356.        write SetGradientInactiveStartColor
  357.        default DEF_GRADIENT_INACTIVE_START_COLOR;
  358.     property GradientInactiveStopColor: TColor
  359.        read FGradientInactiveStopColor
  360.        write SetGradientInactiveStopColor
  361.        stored StoreGradientInactiveStopColor
  362.        default DEF_GRADIENT_INACTIVE_STOP_COLOR;
  363.     {: Determines if and when the gradient caption should be painted.
  364.      <UL>
  365.      <LI>gfpAlways <TAB> The gradient should always be drawn.
  366.      <LI>gfpActive <TAB> Only draw the gradient when the form is active.
  367.      <LI>gfpNever  <TAB> Never draw the gradient.
  368.      </UL> }
  369.     property PaintGradient: TGFPaintWhen
  370.        read FPaintGradient
  371.        write SetPaintGradient
  372.        default DEF_PAINT_GRADIENT;
  373.     property UseWin98Gradient: boolean
  374.        read FUseWin98Gradient
  375.        write SetUseWin98Gradient
  376.        default DEF_USE_WIN98_GRADIENT;
  377.     property UseDithering: boolean
  378.        read FUseDithering
  379.        write SetUseDithering
  380.        default DEF_USE_DITHERING;
  381.     property Logo: TBitmap
  382.        read FLogo
  383.        write SetLogo;
  384.     property InactiveLogo: TBitmap
  385.        read FInactiveLogo
  386.        write SetInactiveLogo;
  387.     property LogoAlign: TGFLogoAlign
  388.        read FLogoAlign
  389.        write SetLogoAlign
  390.        default laRight;
  391.     property LogoLayered: Boolean
  392.        read FLogoLayered
  393.        write SetLogoLayered
  394.        default FALSE;
  395.     {: This event is fired after the icon, buttons and gradient are painted,
  396.        but just before the text is painted.  It is not fired if the caption is
  397.        painted but not as a gradient, that is if
  398.        <See TdfsGradientForm.PaintGradient Text=PaintGradient> is gfpNever or
  399.        gfpActive and the form is not active.<BR><BR> <B>Sender</B> is the
  400.        TdfsGradientForm that is being painted.<BR><BR><B>Canvas</B> is the drawing
  401.        surface that is being painted.  Anything you want to appear on the
  402.        caption must be drawn on this canvas.  This canvas is not the actual
  403.        caption canvas, it is a memory bitmap (non-visible).  This prevents
  404.        flicker as many things are being drawn since the actual visible drawing
  405.        only happens when the entire drawing operation is complete.<BR><BR>
  406.        <B>R</B> is a rectangle that describes the area in which you can draw.
  407.        When the event is first fired, this rectangle will be the entire caption
  408.        less the system icon on the left (if any) and the caption buttons on the
  409.        right (if any).  After performing your drawing operations, this value
  410.        should be modified so that the area you have painted is subtracted out.
  411.        This prevents the gradient from painting over what you have just done. }
  412.     property OnCaptionPaint: TGFOnCaptionPaint
  413.        read FOnCaptionPaint
  414.        write FOnCaptionPaint;
  415.   end;
  416.   
  417. implementation
  418.  
  419. {$R GRADFORM.RES}
  420.  
  421. // A variant record (known as a union in C) to allow easy access to the
  422. // individual red, // green, and blue values of a TColorRef (RGB) value.
  423. type
  424.   TRGBMap = packed record
  425.     case boolean of
  426.       TRUE:  ( RGBVal: DWORD );
  427.       FALSE: ( Red,
  428.                Green,
  429.                Blue,
  430.                Unused: byte );
  431.   end;
  432.  
  433.  
  434. var
  435.   EntrancyFlag: boolean;
  436.  
  437. {: Create creates and initializes an instance of TdfsGradientForm. Call Create
  438.    to instantiate a TdfsGradientForm at runtime.  After calling the inherited
  439.    constructor, Create initializes the following properties:<BR>
  440.    <UL>
  441.    <LI>UsingDefaultGradientStopColor to TRUE.
  442.    <LI>CaptionTextColor to clWhite.
  443.    <LI>GradientStartColor to clBlack.
  444.    <LI>GradientStopColor to clActiveCaption.
  445.    <LI>GradientColors to <See DEF_GRADIENT_COLORS>.
  446.    <LI>PaintGradient to gpfAlways.
  447.    </UL> }
  448. constructor TdfsGradientForm.Create(AOwner: TComponent);
  449. var
  450.   VerInfo: TOSVersionInfo;
  451. begin
  452.   // We set our new property values first so that they will be valid in the
  453.   // OnCreate event handler.  The inherited Create is what calls that event, so
  454.   // we set up first.
  455.  
  456.   FLogo := TBitmap.Create;
  457.   FInactiveLogo := TBitmap.Create;
  458.   FLogoLayered := FALSE;
  459.   FLogoAlign := laRight;
  460.  
  461.   // Are we running under Win98, and should we let it do it for us?
  462.   VerInfo.dwOSVersionInfoSize := SizeOf(VerInfo);
  463.   if GetVersionEx(VerInfo) then
  464.     // this will also catch NT 5.
  465.     FRunningOnWin98 := (VerInfo.dwMajorVersion >= 5) or
  466.        ((VerInfo.dwMajorVersion >= 4) and (VerInfo.dwMinorVersion > 0))
  467.   else
  468.     FRunningOnWin98 := FALSE;
  469.  
  470.   // Are we running on a 16-color system?
  471.   FSystemIs16Color := GetSystemColorBitDepth = 4;
  472.  
  473.   // Don't paint 16-color by default
  474.   FPaint16Color := FALSE;
  475.  
  476.   FUseWin98Gradient := DEF_USE_WIN98_GRADIENT;
  477.   FUseDithering := DEF_USE_DITHERING;
  478.   FUsingDefaultGradientStopColor := TRUE;
  479.   FUsingDefaultGradientInactiveStopColor := TRUE;
  480.   FCaptionTextColor := DEF_CAPTION_TEXT_COLOR;
  481.   FInactiveCaptionTextColor := DEF_INACTIVE_CAPTION_TEXT_COLOR;
  482.   // Set gradient start and stop colors.
  483.   FGradientStartColor := DEF_GRADIENT_START_COLOR;
  484.   FGradientStopColor := DEF_GRADIENT_STOP_COLOR;
  485.   FGradientInactiveStartColor := DEF_GRADIENT_INACTIVE_START_COLOR;
  486.   FGradientInactiveStopColor := DEF_GRADIENT_INACTIVE_STOP_COLOR;
  487.   // Set the number of colors to use to create the gradient fill.
  488.   FGradientColors := DEF_GRADIENT_COLORS;
  489.   // Should we paint the gradient when window is inactive.
  490.   FPaintGradient := DEF_PAINT_GRADIENT;
  491.   FOnCaptionPaint := NIL;
  492.   FChangingActivationState := FALSE;
  493.   // Caption font stuff
  494.   FUseSystemCaptionFont := TRUE;
  495.   FCaptionFont := TFont.Create;
  496.   UpdateCaptionFont;
  497.  
  498.   // Calculate the colors we need to paint the gradient.
  499.   CalculateColors;
  500. //**  CaptionFontHandle := 0;
  501.  
  502. //  inherited Create(AOwner);
  503.  
  504.   CreateNew(AOwner {$IFDEF DFS_CPPB_1}, 1 {$ENDIF});
  505.   if (ClassType <> TdfsGradientForm) and not (csDesigning in ComponentState) then
  506.   begin
  507.     FCreating := TRUE;
  508.     try
  509.       if not InitInheritedComponent(Self, TdfsGradientForm) then
  510.         {$IFDEF DFS_COMPILER_2}
  511.         raise EResNotFound.CreateResFmt(sResNotFound, [ClassName]);
  512.         {$ELSE}
  513.         raise EResNotFound.CreateFmt(sResNotFound, [ClassName]);
  514.         {$ENDIF}
  515.     finally
  516.       FCreating := FALSE;
  517.     end;
  518.  
  519.     // All versions of Delphi, and C4 and up.
  520.     {$IFDEF DFS_DELPHI}
  521.       {$DEFINE DFS_DO_ONCREATE}
  522.     {$ENDIF}
  523.     {$IFDEF DFS_CPPB_4_UP}
  524.       {$DEFINE DFS_DO_ONCREATE}
  525.     {$ENDIF}
  526.     {$IFDEF DFS_DO_ONCREATE}
  527.     try
  528.       if {$IFDEF DFS_COMPILER_4_UP} OldCreateOrder and {$ENDIF}
  529.          assigned(OnCreate) then
  530.         OnCreate(Self);
  531.     except
  532.       Application.HandleException(Self);
  533.     end;
  534.     {$UNDEF DFS_DO_ONCREATE}
  535.     {$ENDIF}
  536.   end;
  537. end;
  538.  
  539.  
  540. {: Destroy destroys an instance of TdfsGradientForm. Do not call Destroy
  541.    directly in an application. Instead, call Free. Free verifies that the
  542.    instance is not already freed, and only then calls Destroy.<BR>
  543.    Destroy is used to free resources allocated in the
  544.    <See Method=TdfsGradientForm.Create Text=Create> constructor. }
  545. destructor TdfsGradientForm.Destroy;
  546. begin
  547.   FLogo.Free;
  548.   FInactiveLogo.Free;
  549.   FCaptionFont.Free;
  550.   // Clean up the font we created.
  551. //**  if CaptionFontHandle <> 0 then
  552. //**    DeleteObject(CaptionFontHandle);
  553.     
  554.   inherited Destroy;
  555. end;
  556.  
  557.  
  558. procedure TdfsGradientForm.Loaded;
  559. begin
  560.   inherited Loaded;
  561.   // Create a font for the caption bar.
  562. //**  CreateCaptionFontHandle;
  563. end;
  564.  
  565.  
  566. procedure TdfsGradientForm.CreateWnd;
  567. begin
  568.   inherited CreateWnd;
  569.   if (not InhibitGradient) and (FormStyle = fsMDIForm) then
  570.   begin
  571.     FGradClientInstance := MakeObjectInstance(GradClientWndProc);
  572.     FGradDefClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
  573.     SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FGradClientInstance));
  574.   end else
  575.     FGradClientInstance := NIL;
  576. //**  if not (csLoading in ComponentState) then
  577.     // Create a font for the caption bar.
  578. //**    CreateCaptionFontHandle;
  579. end;
  580.  
  581. procedure TdfsGradientForm.DestroyWnd;
  582. begin
  583.   if (FormStyle = fsMDIForm) and assigned(FGradClientInstance) then
  584.   begin
  585.     SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FGradDefClientProc));
  586.     FreeObjectInstance(FGradClientInstance);
  587.   end;
  588.  
  589.   inherited DestroyWnd;
  590. end;
  591.  
  592. procedure TdfsGradientForm.SetGradientColors(Val: integer);
  593. begin
  594.   if (Val = FGradientColors) or (Val < MIN_GRADIENT_COLORS) or
  595.      (Val > MAX_GRADIENT_COLORS) then
  596.     exit;
  597.  
  598.   FGradientColors := Val;
  599.   // The number of colors have changed, we need to recalculate the colors we
  600.   // use to paint.
  601.   CalculateColors;
  602.   InvalidateCaption;
  603. end;
  604.  
  605. procedure TdfsGradientForm.SetCaptionTextColor(Color: TColor);
  606. begin
  607.   if FCaptionTextColor = Color then
  608.     exit;
  609.  
  610.   FCaptionTextColor := Color;
  611.   InvalidateCaption;
  612. end;
  613.  
  614. procedure TdfsGradientForm.SetInactiveCaptionTextColor(Color: TColor);
  615. begin
  616.   if FInactiveCaptionTextColor = Color then
  617.     exit;
  618.  
  619.   FInactiveCaptionTextColor := Color;
  620.   InvalidateCaption;
  621. end;
  622.  
  623. procedure TdfsGradientForm.SetGradientStartColor(Color : TColor);
  624. begin
  625.   FGradientStartColor := Color;
  626.   // The colors have changed, we need to recalculate the colors we use to paint.
  627.   CalculateColors;
  628.   InvalidateCaption;
  629. end;
  630.  
  631. procedure TdfsGradientForm.SetGradientStopColor(Color : TColor);
  632. begin
  633.   FGradientStopColor := Color;
  634.   FUsingDefaultGradientStopColor := FGradientStopColor = clActiveCaption;
  635.   // The colors have changed, we need to recalculate the colors we use to paint.
  636.   CalculateColors;
  637.   InvalidateCaption;
  638. end;
  639.  
  640. procedure TdfsGradientForm.SetGradientInactiveStartColor(Color : TColor);
  641. begin
  642.   FGradientInactiveStartColor := Color;
  643.   // The colors have changed, we need to recalculate the colors we use to paint.
  644.   CalculateColors;
  645.   InvalidateCaption;
  646. end;
  647.  
  648. procedure TdfsGradientForm.SetGradientInactiveStopColor(Color : TColor);
  649. begin
  650.   FGradientInactiveStopColor := Color;
  651.   FUsingDefaultGradientInactiveStopColor :=
  652.      (FGradientInactiveStopColor = clInactiveCaption);
  653.   // The colors have changed, we need to recalculate the colors we use to paint.
  654.   CalculateColors;
  655.   InvalidateCaption;
  656. end;
  657.  
  658. procedure TdfsGradientForm.SetPaintGradient(Val: TGFPaintWhen);
  659. begin
  660.   if FPaintGradient = Val then
  661.      exit;
  662.  
  663.   FPaintGradient := Val;
  664.   InvalidateCaption;
  665. end;
  666.  
  667. procedure TdfsGradientForm.SetCaptionText(const Val: string);
  668. begin
  669.   if EntrancyFlag then
  670.     exit;
  671.  
  672.   EntrancyFlag := TRUE;
  673.   try
  674.     // Have to do this so the MDI window menus get updated and application
  675.     // titles get updated (taskbar and Alt-Tab text)
  676.     inherited Caption := Val;
  677.  
  678.     FCaptionText := Val;
  679.     if (not InhibitGradient) and HandleAllocated and IsWindowVisible(Handle) then
  680.     begin
  681.       if (FormStyle = fsMDIChild) {and FChangingActivationState} then
  682.       begin
  683.         if WindowState = wsMaximized then
  684.           // Need to cause main form's caption to be redrawn, not the MDI child.
  685.           SetWindowPos(Application.MainForm.Handle, 0, 0, 0, 0, 0,
  686.              SWP_DRAWFRAME or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE
  687.              or SWP_NOZORDER)
  688.         else
  689.           InvalidateCaption;
  690.       end else
  691.         Draw(IsActiveWindow);
  692.     end;
  693.  
  694.   finally
  695.     EntrancyFlag := FALSE;
  696.   end;
  697. end;
  698.  
  699. procedure TdfsGradientForm.SetUseWin98Gradient(Val: boolean);
  700. begin
  701.   if Val <> FUseWin98Gradient then
  702.   begin
  703.     FUseWin98Gradient := Val;
  704.     if HandleAllocated then
  705.     begin
  706.       RecreateWnd;
  707.       // hmmm, how to get it to show again in the IDE?
  708.     end;
  709.   end;
  710. end;
  711.  
  712. procedure TdfsGradientForm.SetUseDithering(Val: boolean);
  713. begin
  714.   if Val <> FUseDithering then
  715.   begin
  716.     FUseDithering := Val;
  717.     InvalidateCaption;
  718.   end;
  719. end;
  720.  
  721. function TdfsGradientForm.IsActiveWindow: boolean;
  722. begin
  723.   if FormStyle = fsMDIChild then
  724.     if assigned(Application.MainForm) then
  725.       Result := (GetActiveWindow = Application.MainForm.Handle) and
  726.                 (TForm(Application.MainForm).ActiveMDIChild = Self)
  727.     else
  728.       Result := FALSE
  729.   else
  730.     Result := GetActiveWindow=Handle;
  731. end;
  732.  
  733. procedure TdfsGradientForm.CalculateColors;
  734. var
  735.   LoColor, HiColor: TRGBMap;
  736.   RedPct,
  737.   GreenPct,
  738.   BluePct: real;
  739.   x,
  740.   Band: integer;
  741. begin
  742.   // Get colors for both active and inactive captions.
  743.   for x := 0 to 1 do
  744.   begin
  745.     if x = 0 then   // inactive captions
  746.     begin
  747.       LoColor.RGBVal := ColorToRGB(FGradientInactiveStartColor);
  748.       HiColor.RGBVal := ColorToRGB(FGradientInactiveStopColor);
  749.     end else begin    // active caption
  750.       LoColor.RGBVal := ColorToRGB(FGradientStartColor);
  751.       HiColor.RGBVal := ColorToRGB(FGradientStopColor);
  752.     end;
  753.     // Figure out the percentage of each RGB value needed for banding
  754.     RedPct   := (HiColor.Red - LoColor.Red)/ (FGradientColors-1);
  755.     GreenPct := (HiColor.Green - LoColor.Green) / (FGradientColors-1);
  756.     BluePct  := (HiColor.Blue - LoColor.Blue) / (FGradientColors-1);
  757.     // Use the percentage of each color to create each band color.
  758.     for Band := 0 to (FGradientColors-1) do
  759.       Colors[x][Band] := RGB(LoColor.Red + round(RedPct * (Band)),
  760.          LoColor.Green + round(GreenPct * (Band)),
  761.          LoColor.Blue + round(BluePct * (Band)));
  762.   end;
  763. end;
  764.  
  765. //**
  766. {procedure TdfsGradientForm.CreateCaptionFontHandle;
  767. var
  768.   NCM: TNonClientMetrics;
  769. begin
  770.   if CaptionFontHandle <> 0 then
  771.     DeleteObject(CaptionFontHandle);
  772.   NCM.cbSize := SizeOf(NCM);
  773.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0) then
  774.   begin
  775.     if BorderStyle in [bsToolWindow, bsSizeToolWin] then
  776.       CaptionFontHandle := CreateFontIndirect(NCM.lfSmCaptionFont)
  777.     else
  778.       CaptionFontHandle := CreateFontIndirect(NCM.lfCaptionFont);
  779.   end else
  780.     CaptionFontHandle := 0;
  781. end;
  782. }
  783.  
  784. // The caption rect is the rectangle we are interested in painting.  This will
  785. // be the area that contains the caption icon, text and buttons.
  786. function TdfsGradientForm.GetCaptionRect: TRect;
  787. begin
  788.   // Designing mode always draws the form as bsSizeable
  789.   if csDesigning in ComponentState then
  790.   begin
  791.     GetWindowRect(Handle, Result);
  792.     // Convert rect from screen (absolute) to client (0 based) coordinates.
  793.     OffsetRect(Result, -Result.Left, -Result.Top);
  794.     // Shrink rectangle to allow for window border.  We let Windows paint it.
  795.     InflateRect(Result, -GetSystemMetrics(SM_CXSIZEFRAME),
  796.        -GetSystemMetrics(SM_CYSIZEFRAME));
  797.     Result.Bottom := Result.Top + GetSystemMetrics(SM_CYCAPTION) - 1;
  798.   end else begin
  799.     // if we have no border style, then just set the rectange empty.
  800.     if BorderStyle = bsNone then
  801.       SetRectEmpty(Result)
  802.     else begin
  803.       GetWindowRect(Handle, Result);
  804.       // Convert rect from screen (absolute) to client (0 based) coordinates.
  805.       OffsetRect(Result, -Result.Left, -Result.Top);
  806.       // Shrink rectangle to allow for window border.  We let Windows paint it.
  807.       if (WindowState = wsMinimized) or (BorderStyle in [bsToolWindow, bsSingle,
  808.         bsDialog]) then
  809.         InflateRect(Result, -GetSystemMetrics(SM_CXFIXEDFRAME),
  810.           -GetSystemMetrics(SM_CYFIXEDFRAME))
  811.       else if BorderStyle in [bsSizeable, bsSizeToolWin] then
  812.         InflateRect(Result, -GetSystemMetrics(SM_CXSIZEFRAME),
  813.           -GetSystemMetrics(SM_CYSIZEFRAME));
  814.  
  815.       // Set the appropriate height of caption bar.
  816.       if BorderStyle in [bsToolWindow, bsSizeToolWin] then
  817.         Result.Bottom := Result.Top + GetSystemMetrics(SM_CYSMCAPTION) - 1
  818.       else
  819.         Result.Bottom := Result.Top + GetSystemMetrics(SM_CYCAPTION) - 1;
  820.     end;
  821.   end;
  822. end;
  823.  
  824. // Paint the icon for the system menu.
  825. procedure TdfsGradientForm.PaintMenuIcon(DC: DFS_HDC; var R: TRect; Active: boolean);
  826. {$IFDEF DFS_COMPILER_2}
  827. const
  828.   LR_COPYFROMRESOURCE = $4000; // Missing from WINDOWS.PAS in Delphi 2!
  829. {$ENDIF}
  830. var
  831.   SmallCopy,
  832.   IconHandle: HIcon;
  833.   Size: integer;
  834. begin
  835.   // Does the form have an icon assigned to it?
  836.   if Icon.Handle <> 0 then
  837.     IconHandle := Icon.Handle
  838.   // If not, does the application have an icon?
  839.   else if Application.Icon.Handle <> 0 then
  840.     IconHandle := Application.Icon.Handle
  841.   // If not, then just use the system defined application icon.
  842.   else
  843.     IconHandle := LoadIcon(0, IDI_APPLICATION);
  844.  
  845.   Size := GetSystemMetrics(SM_CXSMICON);
  846.   SmallCopy := CopyImage(IconHandle, IMAGE_ICON, Size, Size,
  847.      LR_COPYFROMRESOURCE);
  848.   with R do
  849.     // Let CopyImage() make get us a nice 16x16 version of the icon and we'll
  850.     // paint it.
  851.     DrawIconEx(HDC(DC), Left+1, Top+1, SmallCopy, 0, 0, 0, 0, DI_NORMAL);
  852.   DestroyIcon(SmallCopy);
  853.   Inc(R.Left, Size+1);
  854. end;
  855.  
  856. // Paint the given rectangle with the system solid color.
  857. procedure TdfsGradientForm.FillRectSolid(DC: DFS_HDC; const R: TRect;
  858.   Active: boolean; ActiveColor, InactiveColor : TColor);
  859. var
  860.   OldBrush,
  861.   Brush: HBrush;
  862. begin
  863.   // Create a brush with the appropriate color\
  864.   if Active then
  865.     Brush := CreateSolidBrush(ColorToRGB(ActiveColor))
  866.   else
  867.     Brush := CreateSolidBrush(ColorToRGB(InactiveColor));
  868.   // Select that brush into the temporary DC.
  869.   OldBrush := SelectObject(HDC(DC), Brush);
  870.   try
  871.     // Fill the rectangle using the selected brush -- PatBlt is faster than
  872.     // FillRect
  873.     with R do
  874.       PatBlt(HDC(DC), Left, Top, Right-Left, Bottom-Top, PATCOPY);
  875.   finally
  876.     // Clean up the brush
  877.     SelectObject(HDC(DC), OldBrush);
  878.     DeleteObject(Brush);
  879.   end;
  880. end;
  881.  
  882. // Paint the given rectangle with the gradient pattern.
  883. procedure TdfsGradientForm.FillRectGradient(DC: DFS_HDC; const R: TRect;
  884.    Dithered, Active: boolean);
  885.   function MaxInt(I1, I2: integer): integer;
  886.   begin
  887.     if I1 > I2 then
  888.       Result := I1
  889.     else
  890.       Result := I2;
  891.   end;
  892.   function MinInt(I1, I2: integer): integer;
  893.   begin
  894.     if I1 < I2 then
  895.       Result := I1
  896.     else
  897.       Result := I2;
  898.   end;
  899. const
  900.   HorizTileWidth: array[0..1] of Integer = (69, 14);
  901.   HorizTileHeight: array[0..1] of Integer = (30, 28);
  902.   TileResName: array[0..1] of String = ('DFS_DITHGRADMASK1','DFS_DITHGRADMASK2');
  903. var
  904.   OldBmp,
  905.   TmpBmp: HBitmap;
  906.   TmpDC: HDC;
  907.   OldBrush,
  908.   Brush: HBrush;
  909.   Step: real;
  910.   Band: integer;
  911.  
  912.   Width, Height: Integer;
  913.   StartColor, StopColor: DWORD;
  914.   x, y, i: Integer;
  915.   RStart, GStart, BStart: Integer;
  916.   RDiff, GDiff, BDiff: Integer;
  917.   DitherColors, Index: Integer;
  918.   TileBitmap,
  919.   MaskBitmap,
  920.   OffScreenBitmap: TBitmap;
  921.   FromColor,
  922.   ToColor: TColor;
  923.   PixelsToInsert, PixelsNow: Integer;
  924.   ImageList: TImageList;
  925. begin
  926.   Width := R.Right - R.Left;
  927.   if Width < 1 then exit;
  928.   Height := R.Bottom - R.Top;
  929.  
  930.   StartColor := 0;
  931.   Index := 0;
  932.   RStart := 0;
  933.   GStart := 0;
  934.   BStart := 0;
  935.   RDiff := 0;
  936.   GDiff := 0;
  937.   BDiff := 0;
  938.  
  939.   if Dithered then
  940.   begin
  941.     // Dithered style gradient
  942.     if Active then
  943.     begin
  944.       StartColor := ColorToRGB(FGradientStartColor);
  945.       StopColor := ColorToRGB(FGradientStopColor);
  946.     end else begin
  947.       StartColor := ColorToRGB(FGradientInactiveStartColor);
  948.       StopColor := ColorToRGB(FGradientInactiveStopColor);
  949.     end;
  950.  
  951.     RStart := GetRValue(StartColor);
  952.     GStart := GetGValue(StartColor);
  953.     BStart := GetBValue(StartColor);
  954.     RDiff  := GetRValue(StopColor) - RStart;
  955.     GDiff  := GetGValue(StopColor) - GStart;
  956.     BDiff  := GetBValue(StopColor) - BStart;
  957.  
  958.     if (Abs(RDiff) + Abs(GDiff) + Abs(BDiff)) / Width < 200.0 / 280.0 then
  959.       Index := 0
  960.     else
  961.       Index := 1;
  962.  
  963.     // Want dithering, but make sure it will look good.
  964.     if (Width < HorizTileWidth[Index] shl 1) or (GetDeviceCaps(HDC(DC),
  965.        SIZEPALETTE) > 0) then
  966.       Dithered := FALSE; // Low color mode, dithering will look horrible.
  967.   end;
  968.  
  969.   if Dithered then
  970.   begin
  971.     OffScreenBitmap := TBitmap.Create;
  972.     try
  973.       OffScreenBitmap.Width := Width;
  974.       OffScreenBitmap.Height := Height;
  975.  
  976.       // if dithering is on, we caluclate the number of colors from the width
  977.       DitherColors := (Width div HorizTileWidth[Index]) + 1;
  978.       if Width mod HorizTileWidth[Index] > 0 then
  979.       // if the width is not the multiple of HorizTileWidth, additional pixels
  980.       // must be inserted between the tiles
  981.         PixelsToInsert := Width - (DitherColors - 1) * HorizTileWidth[Index]
  982.       else
  983.         PixelsToInsert := 0;
  984.  
  985.       // setting up the temp bitmap and loading the tile mask
  986.       ImageList := TImageList.CreateSize(HorizTileWidth[Index],
  987.          HorizTileHeight[Index]);
  988.       MaskBitmap := TBitmap.Create;
  989.       TileBitmap := TBitmap.Create;
  990.       try
  991.         MaskBitmap.LoadFromResourceName(HInstance, TileResName[Index]);
  992.         TileBitmap.Width := HorizTileWidth[Index];
  993.         TileBitmap.Height := HorizTileHeight[Index];
  994.  
  995.         x := 0;
  996.         FromColor := StartColor;
  997.         for i := 1 to DitherColors do
  998.         begin
  999.           // calculating the next color
  1000.           ToColor := RGB(
  1001.              MinInt(MaxInt(RStart + MulDiv(i, RDiff, DitherColors - 1), 0), 255),
  1002.              MinInt(MaxInt(GStart + MulDiv(i, GDiff, DitherColors - 1), 0), 255),
  1003.              MinInt(MaxInt(BStart + MulDiv(i, BDiff, DitherColors - 1), 0), 255));
  1004.           // colorizing the tile mask
  1005.           TileBitmap.Canvas.Brush.Color := FromColor;
  1006.           PatBlt(TileBitmap.Canvas.Handle, 0, 0, HorizTileWidth[Index],
  1007.              HorizTileHeight[Index], PATCOPY);
  1008.           if ImageList.Count = 0 then
  1009.             ImageList.Add(TileBitmap, MaskBitmap)
  1010.           else
  1011.             ImageList.Replace(0, TileBitmap, MaskBitmap);
  1012.           with OffScreenBitmap do
  1013.           begin
  1014.             // painting the tile mask
  1015.             Canvas.Brush.Color := ToColor;
  1016.             PatBlt(Canvas.Handle, x, 0, x + HorizTileWidth[Index], Height,
  1017.                PATCOPY);
  1018.  
  1019.             y := 0;
  1020.             while y < Height do
  1021.             begin
  1022.               ImageList.Draw(Canvas, x, y, 0);
  1023.               Inc(y, HorizTileHeight[Index]);
  1024.             end;
  1025.  
  1026.             Inc(x, HorizTileWidth[Index]);
  1027.             // inserting the extra pixels if necessary
  1028.             if PixelsToInsert <> 0 then
  1029.             begin
  1030.               PixelsNow := PixelsToInsert div (DitherColors - 2);
  1031.               if i < PixelsToInsert mod (DitherColors - 2) then
  1032.                 Inc(PixelsNow);
  1033.               PatBlt(Canvas.Handle, x, 0, x + PixelsNow, Height, PATCOPY);
  1034.               Inc(x, PixelsNow);
  1035.             end;
  1036.           end;
  1037.           FromColor := ToColor;
  1038.         end;
  1039.       finally
  1040.         TileBitmap.Free;
  1041.         MaskBitmap.Free;
  1042.         ImageList.Free;
  1043.       end;
  1044.  
  1045.       BitBlt(HDC(DC), R.Left, R.Top, Width, Height,
  1046.          OffScreenBitmap.Canvas.Handle, 0, 0, SRCCOPY);
  1047.     finally
  1048.       OffScreenBitmap.Free;
  1049.     end;
  1050.  
  1051.   end else begin
  1052.     // "Banded" style gradient
  1053.  
  1054.     // This may look backwards, but it's not.  If the device capabilities
  1055.     // indicate that there are palette entries (more than 0), then we are in
  1056.     // a low color mode.  This is because when in high color mode or above,
  1057.     // Windows doesn't use palettes; each pixel knows it's RGB value.
  1058.     if (GetDeviceCaps(HDC(DC), SIZEPALETTE) > 0) or 
  1059.        (Width < GradientColors) then
  1060.     begin
  1061.       // Low color gradient, slower
  1062.  
  1063.       // Determine how large each band should be in order to cover the
  1064.       // rectangle (one band for every color intensity level).
  1065.       Step := Width / FGradientColors;
  1066.  
  1067.       // Start filling bands
  1068.       for Band := 0 to (FGradientColors-1) do
  1069.       begin
  1070.         // Create a brush with the appropriate color for this band
  1071.         Brush := CreateSolidBrush(Colors[ord(Active)][Band]);
  1072.         // Select that brush into the temporary DC.
  1073.         OldBrush := SelectObject(HDC(DC), Brush);
  1074.         try
  1075.           // Fill the rectangle using the selected brush -- PatBlt is faster
  1076.           // than FillRect
  1077.           PatBlt(HDC(DC), round(Band*Step) + R.Left, 0,
  1078.              round((Band+1)*Step) - round(Band*Step), Height, PATCOPY);
  1079.         finally
  1080.           // Clean up the brush
  1081.           SelectObject(HDC(DC), OldBrush);
  1082.           DeleteObject(Brush);
  1083.         end;
  1084.       end; // for
  1085.     end else begin
  1086.       // High color gradient, faster
  1087.       TmpDC := CreateCompatibleDC(HDC(DC));
  1088.       TmpBmp := CreateCompatibleBitmap(HDC(DC), FGradientColors, 1);
  1089.       OldBmp := SelectObject(TmpDC, TmpBmp);
  1090.       try
  1091.         // Start filling bands
  1092.         for Band := 0 to (FGradientColors-1) do
  1093.           SetPixel(TmpDC, Band, 0, Colors[ord(Active)][Band]);
  1094.         StretchBlt(HDC(DC), R.Left, 0, Width, Height, TmpDC, 0, 0,
  1095.            FGradientColors-1, 1, SRCCOPY);
  1096.       finally
  1097.         SelectObject(TmpDC, OldBmp);
  1098.         DeleteObject(TmpBmp);
  1099.         DeleteDC(TmpDC);
  1100.       end;
  1101.     end;
  1102.   end;
  1103. end;
  1104.  
  1105. procedure TdfsGradientForm.PaintCaptionText(DC: DFS_HDC; R: TRect; Active: boolean);
  1106. var
  1107.   OldColor: TColorRef;
  1108.   OldMode: integer;
  1109.   OldFont: HFont;
  1110.   CaptionText: string;
  1111. begin
  1112.   CaptionText := Caption;
  1113.   // Have to turn off complete boolean eval for this "if" statement.  I never
  1114.   // have it on anyway, but some do.
  1115.   {$IFOPT B+} {$DEFINE DFS_RESET_BOOL_EVAL} {$B-} {$ENDIF}
  1116.   if ((FormStyle = fsMDIForm) and (ActiveMDIChild <> NIL) and
  1117.       (ActiveMDIChild.WindowState = wsMaximized)) then
  1118.     CaptionText := CaptionText + ' - [' + ActiveMDIChild.Caption + ']';
  1119.   {$IFDEF DFS_RESET_BOOL_EVAL} {$B+} {$UNDEF DFS_RESET_BOOL_EVAL} {$ENDIF}
  1120.  
  1121.   Inc(R.Left, 2);
  1122.  
  1123.   // Set the color to paint the text with.
  1124.   if Active then
  1125.     OldColor := SetTextColor(HDC(DC), ColorToRGB(FCaptionTextColor))
  1126.   else
  1127.     OldColor := SetTextColor(HDC(DC), ColorToRGB(FInactiveCaptionTextColor));
  1128.   // Set the background text painting mode to transparent so that drawing text
  1129.   // doesn't distrub the gradient we just painted.  If you didn't do this, then
  1130.   // drawing text would also fill the text rectangle with a solid background
  1131.   // color, screwing up our gradient.
  1132.   OldMode := SetBkMode(HDC(DC), TRANSPARENT);
  1133.   // Select in the system defined caption font (see Create constructor).
  1134.   if FCaptionFont.Handle <> 0 then
  1135. //**  if CaptionFontHandle <> 0 then
  1136.     OldFont := SelectObject(HDC(DC), FCaptionFont.Handle)
  1137. //**    OldFont := SelectObject(HDC(DC), CaptionFontHandle)
  1138.   else
  1139.     OldFont := 0;
  1140.   try
  1141.     // Draw the text making it left aligned, centered vertically, allowing no
  1142.     // line breaks.
  1143.     DrawText(HDC(DC), PChar(CaptionText), -1, R, DT_LEFT or DT_VCENTER or
  1144.        DT_SINGLELINE or DT_END_ELLIPSIS);
  1145.   finally
  1146.     // Clean up all the drawing objects.
  1147.     if OldFont <> 0 then
  1148.       SelectObject(HDC(DC), OldFont);
  1149.     SetBkMode(HDC(DC), OldMode);
  1150.     SetTextColor(HDC(DC), OldColor);
  1151.   end;
  1152. end;
  1153.  
  1154. // Paint the min/max/help/close buttons.
  1155. procedure TdfsGradientForm.PaintCaptionButtons(DC: DFS_HDC; var Rect: TRect);
  1156. var
  1157.   BtnWidth: integer;
  1158.   Flag: UINT;
  1159.   SrcRect: TRect;
  1160.   ABorderStyle: TFormBorderStyle;
  1161.   ABorderIcons: TBorderIcons;
  1162. begin
  1163.   SrcRect := Rect;
  1164.   InflateRect(SrcRect, -2, -2);
  1165.   if csDesigning in ComponentState then
  1166.   begin
  1167.     // While designing, the min/max buttons are always shown in a sizeable frame
  1168.     ABorderStyle := bsSizeable;
  1169.     ABorderIcons := [biSystemMenu, biMinimize, biMaximize];
  1170.   end else begin
  1171.     ABorderStyle := BorderStyle;
  1172.     ABorderIcons := BorderIcons;
  1173.   end;
  1174.  
  1175.   if ABorderStyle in [bsToolWindow, bsSizeToolWin] then
  1176.   begin
  1177.     // Tool windows only have the close button, nothing else.
  1178.     with SrcRect do
  1179.       Left := Right - (GetSystemMetrics(SM_CXSMSIZE)) + 2;
  1180.     Flag := DFCS_CAPTIONCLOSE;
  1181.     if (GetClassLong(Handle, GCL_STYLE) and CS_NOCLOSE) <> 0 then
  1182.       Flag := Flag or DFCS_INACTIVE;
  1183.     DrawFrameControl(HDC(DC), SrcRect, DFC_CAPTION, Flag);
  1184.     Rect.Right := SrcRect.Left-5;
  1185.   end else begin
  1186.     BtnWidth := GetSystemMetrics(SM_CXSMICON)-2;
  1187.     { Windows is loopy.  It always returns an even number, no matter what }
  1188.     if (Odd(BtnWidth) XOR Odd(Rect.Bottom-Rect.Top)) then
  1189.       inc(BtnWidth);
  1190.     SrcRect.Left := SrcRect.Right - BtnWidth - 2;
  1191.     // if it has system menu, it has a close button.
  1192.     if biSystemMenu in ABorderIcons then
  1193.     begin
  1194.       Flag := DFCS_CAPTIONCLOSE;
  1195.       if (GetClassLong(Handle, GCL_STYLE) and CS_NOCLOSE) <> 0 then
  1196.         Flag := Flag or DFCS_INACTIVE;
  1197.       DrawFrameControl(HDC(DC), SrcRect, DFC_CAPTION, Flag);
  1198.       OffsetRect(SrcRect, -BtnWidth-4, 0);
  1199.       Dec(Rect.Right,BtnWidth+4);
  1200.     end;
  1201.     // Minimize and Maximized don't show up at all if BorderStyle is bsDialog or
  1202.     // if neither of them are enabled.
  1203.     if (ABorderStyle in [bsSizeable, bsSingle]) and
  1204.        (ABorderIcons * [biMinimize, biMaximize] <> []) then
  1205.     begin
  1206.       if WindowState = wsMaximized then
  1207.         Flag := DFCS_CAPTIONRESTORE
  1208.       else
  1209.         Flag := DFCS_CAPTIONMAX;
  1210.       // if it doesn't have max in style, then it shows up disabled.
  1211.       if not (biMaximize in ABorderIcons) then
  1212.         Flag := Flag or DFCS_INACTIVE;
  1213.  
  1214.       DrawFrameControl(HDC(DC), SrcRect, DFC_CAPTION, Flag);
  1215.       OffsetRect(SrcRect, -BtnWidth-2, 0);
  1216.       Dec(Rect.Right,BtnWidth+2);
  1217.  
  1218.       if WindowState = wsMinimized then
  1219.         Flag := DFCS_CAPTIONRESTORE
  1220.       else
  1221.         Flag := DFCS_CAPTIONMIN;
  1222.       // if it doesn't have min in style, then it shows up disabled.
  1223.       if not (biMinimize in ABorderIcons) then
  1224.         Flag := Flag or DFCS_INACTIVE;
  1225.  
  1226.       DrawFrameControl(HDC(DC), SrcRect, DFC_CAPTION, Flag);
  1227.       OffsetRect(SrcRect, -BtnWidth-2, 0);
  1228.       Dec(Rect.Right,BtnWidth+2);
  1229.     end;
  1230.  
  1231.     // Help only shows up in bsDialog style, and bsSizeable, bsSingle when there
  1232.     // is no min or max button.
  1233.     if biHelp in ABorderIcons then
  1234.     begin
  1235.       if ((ABorderStyle in [bsSizeable, bsSingle]) and
  1236.          (ABorderIcons * [biMinimize, biMaximize] = [])) or
  1237.          (ABorderStyle = bsDialog) then
  1238.       begin
  1239.         DrawFrameControl(HDC(DC), SrcRect, DFC_CAPTION, DFCS_CAPTIONHELP);
  1240.         Dec(Rect.Right,BtnWidth+2);
  1241.       end;
  1242.     end;
  1243.  
  1244.     Dec(Rect.Right, 3);
  1245.   end;
  1246. end;
  1247.  
  1248.  
  1249. function TdfsGradientForm.DrawCaption(FormDC: DFS_HDC; Active: boolean): TRect;
  1250. var
  1251.   R: TRect;
  1252.   OldBmp,
  1253.   Bmp: HBitmap;
  1254.   BmpDC: HDC;
  1255.   BmpCanvas: TCanvas;
  1256.   w,h:integer;
  1257.   IsLogoGradient : Boolean;
  1258.   GradientRect, LogoRect : TRect;
  1259.   LogoWidth : Integer;
  1260.   CurrentLogo : TBitmap;
  1261. begin
  1262.   // Get only the portion we need to draw.
  1263.   R := GetCaptionRect;
  1264.   Result := R;
  1265.  
  1266.   // Convert to logical (0-based) coordinates
  1267.   OffsetRect(R, -R.Left, -R.Top);
  1268.  
  1269.   W := R.Right - R.Left;
  1270.   H := R.Bottom - R.Top;
  1271.  
  1272.   // Create a temporary device context to draw on.  Drawing on a temporary DC
  1273.   // and copying it to the real DC accomplishes two things:
  1274.   // 1) It is faster because Windows doesn't have to draw anything in the
  1275.   //    temporary DC on the screen, it only draws when you paint something on a
  1276.   //    real DC.  Then it just draws everything at once when we copy it, instead
  1277.   //    of drawing a little, do some calculations, draw a little, etc.
  1278.   // 2) It looks much better because it is drawn faster.  It reduces the
  1279.   //    "flicker" that you would see from each individual part being drawn,
  1280.   //    especially the gradient bands.
  1281.   BmpDC := CreateCompatibleDC(HDC(FormDC));
  1282.   Bmp := CreateCompatibleBitmap(HDC(FormDC), W, H);
  1283.   OldBmp := SelectObject(BmpDC, Bmp);
  1284.  
  1285.   try
  1286.     // If there's a logo bitmap, we need a solid background
  1287.     // behind the menu icon, the caption buttons, and the
  1288.     // logo; so we need to delay drawing of the gradient
  1289.     // until after the menu and buttons are painted.
  1290.     IsLogoGradient := FALSE;
  1291.  
  1292.     if (FPaintGradient = gfpAlways) or
  1293.        (Active and (FPaintGradient = gfpActive)) then
  1294.     begin
  1295.       if (Assigned (FLogo)) and (not FLogo.Empty) then
  1296.       begin
  1297.         IsLogoGradient := TRUE;
  1298.         FillRectSolid(DFS_HDC (BmpDC), R, Active, GradientStartColor,
  1299.           GradientInactiveStartColor);
  1300.       end
  1301.       else
  1302.         // Draw the gradient background in the temporary DC
  1303.         FillRectGradient(DFS_HDC(BmpDC), R, UseDithering, Active)
  1304.     end
  1305.     else
  1306.       FillRectSolid(DFS_HDC(BmpDC), R, Active, GetSysColor(COLOR_ACTIVECAPTION),
  1307.         GetSysColor(COLOR_INACTIVECAPTION));
  1308.  
  1309.     Inc(R.Left, 1);
  1310.     // Do we need to paint an icon for the system menu?
  1311.     if not ((FormStyle = fsMDIChild) and (WindowState = wsMaximized)) then
  1312.     begin
  1313.       if IsLogoGradient then
  1314.       begin
  1315.         // Start by drawing the solid-color end of the bar.
  1316.         // There's a solid color under the menu icon if the
  1317.         // logo is left-aligned, or under the caption buttons
  1318.         // if the logo is right-aligned.
  1319.         if LogoAlign = laLeft then
  1320.         begin
  1321.           if ((biSystemMenu in BorderIcons) and
  1322.              (BorderStyle in [bsSingle, bsSizeable])) or
  1323.              (csDesigning in ComponentState) then
  1324.           begin
  1325.             FillRectSolid(DFS_HDC (BmpDC), R, Active, GradientStartColor,
  1326.               GradientInactiveStartColor);
  1327.             // PaintMenuIcon will adjust the rect so that future drawing operations
  1328.             // happen in the right spot.
  1329.             PaintMenuIcon(DFS_HDC(BmpDC), R, Active);
  1330.           end;
  1331.         end
  1332.         else  // LogoAlign = laRight
  1333.         begin
  1334.           FillRectSolid(DFS_HDC(BmpDC), R, Active, GradientStopColor,
  1335.             GradientInactiveStopColor);
  1336.           PaintCaptionButtons(DFS_HDC(BmpDC), R);
  1337.         end;
  1338.  
  1339.         if (not Active) and (not FInactiveLogo.Empty) then
  1340.           CurrentLogo := FInactiveLogo
  1341.         else
  1342.           CurrentLogo := FLogo;
  1343.  
  1344.         LogoWidth := CurrentLogo.Width;
  1345.  
  1346.         if LogoAlign = laLeft then
  1347.           LogoRect := Rect(R.Left, R.Top, R.Left + LogoWidth, R.Bottom)
  1348.         else
  1349.           LogoRect := Rect(R.Right - LogoWidth, R.Top, R.Right, R.Bottom);
  1350.  
  1351.         // Make sure LogoRect doesn't fall off the edge
  1352.         // of our drawable area (between icon and buttons)
  1353.         IntersectRect (LogoRect, LogoRect, R);
  1354.  
  1355.         if LogoAlign = laLeft then
  1356.           GradientRect := Rect(LogoRect.Right, R.Top, R.Right, R.Bottom)
  1357.         else
  1358.           GradientRect := Rect(R.Left, R.Top, LogoRect.Left, R.Bottom);
  1359.  
  1360.         if GradientRect.Right > GradientRect.Left then
  1361.           FillRectGradient(DFS_HDC(BmpDC), GradientRect, UseDithering, Active);
  1362.  
  1363.         BitBlt(BmpDC, LogoRect.Left, (LogoRect.Bottom - LogoRect.Top -
  1364.           CurrentLogo.Height) div 2 + LogoRect.Top, LogoRect.Right -
  1365.           LogoRect.Left, CurrentLogo.Height, CurrentLogo.Canvas.Handle, 0, 0,
  1366.           SRCCOPY);
  1367.  
  1368.         // Now draw the caption stuff that needs a gradient:
  1369.         // caption buttons if logo is left-aligned, or icon
  1370.         // if logo is right-aligned.
  1371.         if LogoAlign <> laLeft then
  1372.         begin
  1373.           if ((biSystemMenu in BorderIcons) and
  1374.              (BorderStyle in [bsSingle, bsSizeable])) or
  1375.              (csDesigning in ComponentState) then
  1376.           // PaintMenuIcon will adjust the rect so that future drawing operations
  1377.           // happen in the right spot.
  1378.           PaintMenuIcon(DFS_HDC(BmpDC), R, Active);
  1379.         end
  1380.         else  // LogoAlign = laRight
  1381.           PaintCaptionButtons(DFS_HDC(BmpDC), R);
  1382.  
  1383.         if not LogoLayered then
  1384.           IntersectRect(R, R, GradientRect);
  1385.  
  1386.         // Done drawing the gradient, icon, caption buttons, and logo.
  1387.       end
  1388.       else
  1389.       begin
  1390.         if ((biSystemMenu in BorderIcons) and
  1391.            (BorderStyle in [bsSingle, bsSizeable])) or
  1392.            (csDesigning in ComponentState) then
  1393.           // PaintMenuIcon will adjust the rect so that future drawing operations
  1394.           // happen in the right spot.
  1395.           PaintMenuIcon(DFS_HDC(BmpDC), R, Active);
  1396.  
  1397.         PaintCaptionButtons(DFS_HDC(BmpDC), R); // Paint the min/max/help/close buttons.
  1398.       end;
  1399.     end;
  1400.     if assigned(FOnCaptionPaint) then
  1401.     begin
  1402.       BmpCanvas := TCanvas.Create;
  1403.       try
  1404.         BmpCanvas.Handle := BmpDC;
  1405. //        BmpCanvas.Font.handle := FCaptionFont.handle;
  1406.         BmpCanvas.Font := FCaptionFont;
  1407.  
  1408.         FOnCaptionPaint(Self, BmpCanvas, R);
  1409.       finally
  1410.         BmpCanvas.Free;
  1411.       end;
  1412.     end;
  1413.     PaintCaptionText(DFS_HDC(BmpDC), R, Active); // Paint the caption text.
  1414.     // Copy the gradient caption bar to the real DC.
  1415.     BitBlt(HDC(FormDC), Result.Left, Result.Top, W, H, BmpDC, 0, 0, SRCCOPY);
  1416.   finally
  1417.     // Clean up all the temporary drawing objects.
  1418.     SelectObject(BmpDC, OldBmp);
  1419.     DeleteObject(Bmp);
  1420.     DeleteDC(BmpDC);
  1421.   end;
  1422. end;
  1423.  
  1424. // Windows sends this message when the window has been activated or deactivated.
  1425. procedure TdfsGradientForm.WMNCActivate(var Msg: TWMNCActivate);
  1426. begin
  1427.   if not InhibitGradient then
  1428.   begin
  1429.     Msg.Result := 1;
  1430.     // I can't remember what the "bad things" were, and I can't find any problems
  1431.     // now if I don't call it.... If some new bug shows up, this is the first
  1432.     // place to look. 
  1433. {    if FormStyle in [fsMDIForm, fsMDIChild] then
  1434.       inherited; { Call inherited or bad things will happen with MDI }
  1435.     Draw(Msg.Active);
  1436.   end else
  1437.     inherited;
  1438. end;
  1439.  
  1440. // Windows sends this message whenever any part of the non-client area
  1441. // (caption, window border) needs repainting.
  1442. procedure TdfsGradientForm.WMNCPaint(var Msg: TMessage);
  1443. var
  1444. {$IFDEF DFS_COMPILER_4_UP}
  1445.   SaveWR, CR,
  1446. {$ENDIF}
  1447.   WR, R: TRect;
  1448.   DC: HDC;
  1449.   MyRgn: HRGN;
  1450.   DeleteRgn: boolean;
  1451. begin
  1452.   if not InhibitGradient then
  1453.   begin
  1454.     DeleteRgn := FALSE;
  1455.     // The region that needs painting is passed in WParam.  A region is a Windows
  1456.     // object used to describe the non-rectangular area used by a combination of
  1457.     // rectangles.  We have to typecast it because in Delphi 4 wParam is signed
  1458.     // and HRGN in unsigned.  It worked prior to D4 because they were both
  1459.     // signed.
  1460.     MyRgn := HRGN(Msg.wParam);
  1461.     DC := GetWindowDC(Handle);
  1462.     try
  1463.       GetWindowRect(Handle, WR);
  1464.       // Select the update region as the clipping region.  Clipping regions
  1465.       // guarantee that any painting done outside of the selected region is not
  1466.       // shown (thrown away).
  1467.       if SelectClipRgn(DC, MyRgn) = ERROR then
  1468.       begin
  1469.         // We got passed an invalid region.  Generally, this happens when the
  1470.         // window is first created or a MDI is minimized.  We'll create our own
  1471.         // region (the rectangle that makes up the entire window) and use that
  1472.         // instead.
  1473.         with WR do
  1474.           MyRgn := CreateRectRgn(Left, Top, Right, Bottom);
  1475.         SelectClipRgn(DC, MyRgn);
  1476.         DeleteRgn := TRUE;
  1477.       end;
  1478.       // Convert the clipping region coordinates from screen to client.
  1479.       OffsetClipRgn(DC, -WR.Left, -WR.Top);
  1480.       // Draw our gradient caption.
  1481.       R := DrawCaption(DFS_HDC(DC), IsActiveWindow);
  1482.       // Here's the trick.  DrawCaption returns the rectangle that we painted.
  1483.       // We now exclude that rectangle from the clipping region.  This guarantees
  1484.       // that any further painting that occurs will not happen in this rectangle.
  1485.       // That means that when we let the default painting for WM_NCPAINT occur,
  1486.       // it will not paint over our gradient. It only paints the stuff that we
  1487.       // didn't, like the window borders.
  1488.       ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
  1489.  
  1490. {$IFDEF DFS_COMPILER_4_UP}
  1491.       // Draw border if needed
  1492.       if BorderWidth > 0 then
  1493.       begin
  1494.         Windows.GetClientRect(Handle, CR);
  1495.         SaveWR := WR;
  1496.         MapWindowPoints(0, Handle, WR, 2);
  1497.         OffsetRect(CR, -WR.Left, -WR.Top);
  1498.         { Draw borders in non-client area }
  1499.         InflateRect(CR, BorderWidth, BorderWidth);
  1500.         WR := SaveWR;
  1501.         OffsetRect(WR, -WR.Left, -WR.Top);
  1502.         Windows.FillRect(DC, WR, Brush.Handle);
  1503.         WR := SaveWR;
  1504.       end;
  1505. {$ENDIF}
  1506.  
  1507.       // Convert coordinates back into screen-based.
  1508.       OffsetClipRgn(DC, WR.Left, WR.Top);
  1509.       // Get the region that is now described by the clipping region.
  1510.       GetClipRgn(DC, MyRgn);
  1511.       // Pass that region on to the default WM_NCPAINT handler.  Remember, we
  1512.       // excluded the rectangle that we painted, so Windows will not be able to
  1513.       // paint over what we did. Most gradient captions components just let
  1514.       // windows draw its stuff first, and then paint the gradient.  This results
  1515.       // in an irritating "flicker", caused by the area being painted normally,
  1516.       // and then painted over a second time by the gradient. We have to
  1517.       // typecast the wParam parameter because in Delphi 4 wParam is signed and
  1518.       // HRGN in unsigned.  It worked prior to D4 because they were both signed.
  1519.       Msg.Result := DefWindowProc(Handle, Msg.Msg, WPARAM(MyRgn), Msg.lParam);
  1520.     finally
  1521.       // If we had to create our own region, we have to clean it up.
  1522.       if DeleteRgn then
  1523.         DeleteObject(MyRgn);
  1524.       ReleaseDC(Handle, DC); // NEVER leave this hanging.
  1525.     end;
  1526.   end else
  1527.     inherited;
  1528. end;
  1529.  
  1530. // Windows sends this message if the user changes any of the system colors.
  1531. procedure TdfsGradientForm.WMSysColorChange(var Msg: TWMSysColorChange);
  1532. var
  1533.   x: integer;
  1534. begin
  1535.   // Did they change to 16-color mode?
  1536.   FSystemIs16Color := GetSystemColorBitDepth = 4;
  1537.  
  1538.   if not InhibitGradient then
  1539.   begin
  1540.     if FUsingDefaultGradientStopColor then
  1541.       FGradientStopColor := clActiveCaption;
  1542.     if FUsingDefaultGradientInactiveStopColor then
  1543.       FGradientInactiveStopColor := clInactiveCaption;
  1544.     CalculateColors;
  1545.     // This only goes to top-level windows so we have to feed it to MDI children
  1546.     if FormStyle = fsMDIForm then
  1547.     begin
  1548.       for x := 0 to MDIChildCount-1 do
  1549.         if MDIChildren[x] is TdfsGradientForm then
  1550.           TdfsGradientForm(MDIChildren[x]).WMSysColorChange(Msg);
  1551.     end;
  1552.   end;
  1553.   inherited;
  1554. end;
  1555.  
  1556. // The window has been resized.
  1557. procedure TdfsGradientForm.WMSize(var Msg: TWMSize);
  1558. begin
  1559.   inherited;
  1560.   if not InhibitGradient then
  1561.   begin
  1562.     // If the window was maximized or restored, we need to redraw so the right
  1563.     // caption button is painted.
  1564.     if (Msg.SizeType = SIZE_MAXIMIZED) or (Msg.SizeType = SIZE_RESTORED) then
  1565.       Draw(IsActiveWindow);
  1566.   end;
  1567. end;
  1568.  
  1569. // Windows would like to have a cursor displayed.  I know, you're wondering
  1570. // why the hell I care about this, aren't you?  Well, in the inherited handling
  1571. //  (default Windows processing) of this message, if the mouse is over a
  1572. // resizeable border section, Windows repaints the caption buttons.  Why?  I
  1573. // have absolutely no idea.  However, that's not the important part.  When it
  1574. // repaints those buttons, it also repaints the background around them in the
  1575. // last color it painted the caption in.  Now, usually this would just result
  1576. // in losing a few bands of the caption gradient, which 99.44% of all users
  1577. // would never notice.  However, because we don't always allow default
  1578. // processing of WM_NCACTIVATE, sometimes Windows doesn't have the right idea
  1579. // about which color is currently the background.  This cause the background to
  1580. // get painted in the wrong color sometimes, which 99.44% of all users *will*
  1581. // notice.  We fix it by setting the appropriate cursor and not allowing the
  1582. // default processing to occur.
  1583. procedure TdfsGradientForm.WMSetCursor(var Msg: TWMSetCursor);
  1584. begin
  1585.   if not InhibitGradient then
  1586.   begin
  1587.     // Tell Windows we handled the message
  1588.     Msg.Result := 1;
  1589.     // Load and display the correct cursor for the border area being hit
  1590.     case Msg.HitTest of
  1591.       HTTOP,
  1592.       HTBOTTOM:      SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENS)));
  1593.       HTLEFT,
  1594.       HTRIGHT:       SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZEWE)));
  1595.       HTTOPRIGHT,
  1596.       HTBOTTOMLEFT:  SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENESW)));
  1597.       HTTOPLEFT,
  1598.       HTBOTTOMRIGHT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENWSE)));
  1599.     else
  1600.       // Wasn't anything we cared about, so tell Windows we didn't handle it.
  1601.       Msg.Result := 0;
  1602.       inherited;
  1603.     end;
  1604.   end else
  1605.     inherited;
  1606. end;
  1607.  
  1608.  
  1609. procedure TdfsGradientForm.WMSetText(var Msg: TWMSetText);
  1610. var
  1611.   FlagSet: boolean;
  1612.   Wnd: HWND;
  1613. begin
  1614.   if (not InhibitGradient) then
  1615.   begin
  1616.     Wnd := 0;
  1617.     if ((FormStyle = fsMDIChild) and (WindowState = wsMaximized)) then
  1618.     begin
  1619.       // Need to cause main form's caption to be redrawn, not the MDI child.
  1620.       if Application.MainForm.HandleAllocated then
  1621.         Wnd := Application.MainForm.Handle;
  1622.     end else begin
  1623.       if HandleAllocated then
  1624.         Wnd := Handle;
  1625.     end;
  1626.  
  1627.     if (Wnd <> 0) and IsWindowVisible(Wnd) then
  1628.     begin
  1629.       FlagSet := TRUE;
  1630.       // No update region for the window.  changes won't be painted.
  1631.       SetWindowRgn(Wnd, CreateRectRgn(0, 0, 0, 0), FALSE);
  1632.     end else
  1633.       FlagSet := FALSE;
  1634.  
  1635.     // Normally, processing WM_SETTEXT would cause all sorts of flicker as it
  1636.     // changed the caption text of the window.  But, we've told it that the
  1637.     // update region for the window (the portion it is allowed to paint in) is
  1638.     // a NULL region (a rectangle equal to 0, 0, 0, 0).  So, the changes don't
  1639.     // have anywhere to paint now, so it is safe to call inherited at this
  1640.     // point.  After that, we'll restore the window region so that painting
  1641.     // can happen again.
  1642.     inherited;
  1643.  
  1644.     if FlagSet then
  1645.       // Reset region to normal.
  1646.       SetWindowRgn(Wnd, 0, FALSE);
  1647.  
  1648.     // Don't do it if it was called from .SetCaption
  1649.     if not EntrancyFlag then
  1650.       Caption := Msg.Text;
  1651.   end else
  1652.     inherited;
  1653. end;
  1654.  
  1655. procedure TdfsGradientForm.WMGetText(var Msg: TWMGetText);
  1656. begin
  1657.   if not InhibitGradient then
  1658.   begin
  1659.     StrLCopy(Msg.Text, PChar(FCaptionText), Msg.TextMax-1);
  1660.     Msg.Result := StrLen(Msg.Text)+1;
  1661.   end else
  1662.     inherited;
  1663. end;
  1664.  
  1665. procedure TdfsGradientForm.WMGetTextLength(var Msg: TWMGetTextLength);
  1666. begin
  1667.   if not InhibitGradient then
  1668.   begin
  1669.     Msg.Result := Length(FCaptionText);
  1670.   end else
  1671.     inherited;
  1672. end;
  1673.  
  1674. procedure TdfsGradientForm.WMSettingChange(var Msg: TMessage);
  1675. begin
  1676.   if not InhibitGradient then
  1677.   begin
  1678.     // User might have changed NC font.
  1679.     if Msg.wParam = SPI_SETNONCLIENTMETRICS then
  1680.       UpdateCaptionFont;
  1681. //**      CreateCaptionFontHandle;
  1682.   end;
  1683.   inherited;
  1684. end;
  1685.  
  1686. {: This procedure is used to paint the caption gradient.  It is normally
  1687.    called internally, but it can be used any time a repaint of the caption
  1688.    is needed. The <B>Active</B> parameter is used to indicate whether the
  1689.    caption should be painted as the active window or an inactive window. }
  1690. procedure TdfsGradientForm.Draw(Active: boolean);
  1691. var
  1692.   DC: HDC;
  1693. begin
  1694.   if csDestroying in ComponentState then exit;
  1695.   
  1696.   // Get the DC we need to paint in.  GetDC would only get the DC for the
  1697.   // client area, we need it for non-client area, too, so we use GetWindowDC.
  1698.   DC := GetWindowDC(Handle);
  1699.   try
  1700.     DrawCaption(DFS_HDC(DC), Active);
  1701.   finally
  1702.     ReleaseDC(Handle, DC); // NEVER leave this hanging.
  1703.   end;
  1704. end;
  1705.  
  1706. procedure TdfsGradientForm.GradClientWndProc(var Message: TMessage);
  1707. begin
  1708.   with Message do begin
  1709.     Result := CallWindowProc(FGradDefClientProc, ClientHandle, Msg, wParam,
  1710.        lParam);
  1711.     // if you don't want your MDI child forms to be TdfsGradientForm descendants,
  1712.     // you will need to use uncomment the code in the following line.
  1713.     // It will work, but it causes an annoying flicker.
  1714.     // NOTE:  as of v1.55, this is no longer necessary.  Just leave it the way
  1715.     //        it is....I think.....
  1716.  
  1717.     // $003F is a "Magic Number".  I hate this, but it's the only way I could
  1718.     // get it to work.  :(
  1719.     if {(Msg = WM_MDIREFRESHMENU) or} (Msg = $003F) then
  1720.       Draw(IsActiveWindow);
  1721.   end;
  1722. end;
  1723.  
  1724. procedure TdfsGradientForm.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
  1725. begin
  1726.   inherited;
  1727.   if not InhibitGradient then
  1728.     Draw(IsActiveWindow);
  1729. end;
  1730.  
  1731. procedure TdfsGradientForm.WMSysCommand (var Msg : TWMSysCommand);
  1732. begin
  1733.   if not InhibitGradient then
  1734.   begin
  1735.     if Msg.CmdType = SC_CONTEXTHELP then
  1736.       // Help button pressed, do't call Draw() because it will draw it in the up state.
  1737.       inherited
  1738.     else
  1739.     begin
  1740.       Draw(IsActiveWindow);
  1741.       inherited;
  1742.       Draw(IsActiveWindow);
  1743.     end;
  1744.   end else
  1745.     inherited;
  1746. end;
  1747.  
  1748. procedure TdfsGradientForm.WMEnterIdle(var Msg: TWMEnterIdle);
  1749. begin
  1750.   if not InhibitGradient then
  1751.     Draw(IsActiveWindow);
  1752.   inherited;
  1753. end;
  1754.  
  1755. procedure TdfsGradientForm.WMWindowPosChanging(var Msg: TWMWindowPosChanging);
  1756. begin
  1757.   with Msg.WindowPos^ do
  1758.     if FCreating and ((Flags and SWP_HIDEWINDOW) <> 0) then
  1759.       Flags := Flags or SWP_NOREDRAW;
  1760.   inherited;
  1761. end;
  1762.  
  1763. function TdfsGradientForm.StoreGradientStopColor: boolean;
  1764. begin
  1765.   Result := not FUsingDefaultGradientStopColor;
  1766. end;
  1767.  
  1768. function TdfsGradientForm.StoreGradientInactiveStopColor: boolean;
  1769. begin
  1770.   Result := not FUsingDefaultGradientInactiveStopColor;
  1771. end;
  1772.  
  1773. function TdfsGradientForm.Win98Check: boolean;
  1774. begin
  1775.   // Are we running under Win98, and should we let it do it for us?
  1776.   Result := FUseWin98Gradient and FRunningOnWin98;
  1777. end;
  1778.  
  1779. function TdfsGradientForm.GetVersion: string;
  1780. begin
  1781.   Result := DFS_COMPONENT_VERSION;
  1782. end;
  1783.  
  1784. procedure TdfsGradientForm.SetVersion(const Val: string);
  1785. begin
  1786.   { empty write method, just needed to get it to show up in Object Inspector }
  1787. end;
  1788.  
  1789. procedure TdfsGradientForm.Activate;
  1790. begin
  1791.   FChangingActivationState := TRUE;
  1792.   try
  1793.     inherited Activate;
  1794.   finally
  1795.     FChangingActivationState := FALSE;
  1796.   end;
  1797. end;
  1798.  
  1799. procedure TdfsGradientForm.Deactivate;
  1800. begin
  1801.   FChangingActivationState := TRUE;
  1802.   try
  1803.     inherited Deactivate;
  1804.   finally
  1805.     FChangingActivationState := FALSE;
  1806.   end;
  1807. end;
  1808.  
  1809. procedure TdfsGradientForm.DoShow;
  1810. begin
  1811.   FChangingActivationState := TRUE;
  1812.   try
  1813.     inherited DoShow;
  1814.   finally
  1815.     FChangingActivationState := FALSE;
  1816.   end;
  1817. end;
  1818.  
  1819.  
  1820. function TdfsGradientForm.GetSystemColorBitDepth: integer;
  1821. var
  1822.   DC: HDC;
  1823. begin
  1824.   DC := GetDC(0);
  1825.   try
  1826.     Result := (GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL));
  1827.   finally
  1828.     ReleaseDC(0, DC);
  1829.   end;
  1830. end;
  1831.  
  1832. function TdfsGradientForm.GetInhibitGradient: boolean;
  1833. begin
  1834.   Result := Win98Check or (SystemIs16Color and (not Paint16Color));
  1835. end;
  1836.  
  1837. procedure TdfsGradientForm.SetPaint16Color(const Value: boolean);
  1838. begin
  1839.   if FPaint16Color <> Value then
  1840.   begin
  1841.     FPaint16Color := Value;
  1842.     InvalidateCaption;
  1843.   end;
  1844. end;
  1845.  
  1846.  
  1847. procedure TdfsGradientForm.SetCaptionFont(const Value: TFont);
  1848. begin
  1849.   FCaptionFont.Assign(Value);
  1850.   UseSystemCaptionFont := FALSE;
  1851.   UpdateCaptionFont;
  1852. end;
  1853.  
  1854. function TdfsGradientForm.GetSysCaptionLogFont: TLogFont;
  1855. var
  1856.   NCM: TNonClientMetrics;
  1857. begin
  1858.   FillChar(Result, SizeOf(Result), #0);
  1859.   NCM.cbSize := SizeOf(NCM);
  1860.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0) then
  1861.   begin
  1862.     if BorderStyle in [bsToolWindow, bsSizeToolWin] then
  1863.       Result := NCM.lfSmCaptionFont
  1864.     else
  1865.       Result := NCM.lfCaptionFont;
  1866.   end;
  1867. end;
  1868.  
  1869. procedure TdfsGradientForm.SetUseSystemCaptionFont(const Value: boolean);
  1870. begin
  1871.   if FUseSystemCaptionFont <> Value then
  1872.   begin
  1873.     FUseSystemCaptionFont := Value;
  1874.     UpdateCaptionFont;
  1875.   end;
  1876. end;
  1877.  
  1878.  
  1879. procedure TdfsGradientForm.UpdateCaptionFont;
  1880. var
  1881.   CF: TLogFont;
  1882.   NCM: TNonClientMetrics;
  1883.   FS: TFontStyles;
  1884. begin
  1885.   CF := GetSysCaptionLogFont;
  1886.   if FUseSystemCaptionFont then
  1887.   begin
  1888.     NCM.cbSize := SizeOf(NCM);
  1889.     SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0);
  1890.     {$IFDEF DFS_COMPILER_3_UP}
  1891.     FCaptionFont.Charset := TFontCharset(CF.lfCharSet);
  1892.     {$ENDIF}
  1893.     FCaptionFont.Name := CF.lfFaceName;
  1894.     FCaptionFont.Height := CF.lfHeight;
  1895.     case CF.lfPitchAndFamily and $F of
  1896.       VARIABLE_PITCH: FCaptionFont.Pitch := fpVariable;
  1897.       FIXED_PITCH: FCaptionFont.Pitch := fpFixed;
  1898.     else
  1899.       FCaptionFont.Pitch := fpDefault;
  1900.     end;
  1901.     FS := [];
  1902.     if CF.lfWeight >= FW_BOLD then
  1903.       Include(FS, fsBold);
  1904.     if CF.lfItalic = 1 then
  1905.       Include(FS, fsItalic);
  1906.     if CF.lfUnderline = 1 then
  1907.       Include(FS, fsUnderline);
  1908.     if CF.lfStrikeOut = 1 then
  1909.       Include(FS, fsStrikeOut);
  1910.     FCaptionFont.Style := FS;
  1911.   end else
  1912.     FCaptionFont.Height := CF.lfHeight;
  1913.  
  1914.   InvalidateCaption;
  1915. end;
  1916.  
  1917. procedure TdfsGradientForm.SetInactiveLogo(const Value: TBitmap);
  1918. begin
  1919.   FInactiveLogo.Assign(Value);
  1920.   InvalidateCaption;
  1921. end;
  1922.  
  1923. procedure TdfsGradientForm.SetLogo(const Value: TBitmap);
  1924. begin
  1925.   FLogo.Assign(Value);
  1926.   InvalidateCaption;
  1927. end;
  1928.  
  1929. procedure TdfsGradientForm.SetLogoAlign(const Value: TGFLogoAlign);
  1930. begin
  1931.   if FLogoAlign <> Value then
  1932.   begin
  1933.     FLogoAlign := Value;
  1934.     InvalidateCaption;
  1935.   end;
  1936. end;
  1937.  
  1938. procedure TdfsGradientForm.SetLogoLayered(const Value: Boolean);
  1939. begin
  1940.   if FLogoLayered <> Value then
  1941.   begin
  1942.     FLogoLayered := Value;
  1943.     InvalidateCaption;
  1944.   end;
  1945. end;
  1946.  
  1947. procedure TdfsGradientForm.InvalidateCaption;
  1948. begin
  1949.   if HandleAllocated and not InhibitGradient then
  1950.   begin
  1951.     // Make the non client area repaint.
  1952.     SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_DRAWFRAME or SWP_NOACTIVATE or
  1953.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);
  1954.    end;
  1955. end;
  1956.  
  1957. initialization
  1958.   EntrancyFlag := FALSE;
  1959. end.
  1960.  
  1961.