Chip: Shareware for Win 95/Chip-Shareware-Win95.bin/ostatni/delphi/delphi1/form3d.exe/FORM3D.PAS

Pascal/Delphi Source File | 1995-09-13 | 18KB | 559 lines

unit Form3d;

{
  TForm3D Class
  Copyright ⌐ 1995  Alan Ciemian  All Rights Reserved

  The TForm3D class is a descendant of TForm that provides
    3D borders for non-dialog forms. Also allows form sizing to be
    enabled/disabled.

  NOTES:
      - Requires that form have bsSizeable border style.
      - Sizing can be enabled/disabled with AllowResize property.
      - Handles all Title bar icon combinations.
      - Handles forms with or without menus(including multiline).
      - Handles all combinations of scroll bars.
      - DOES NOT work properly for MDI Frame or MDI Child windows.

  05/01/95 - Initial Release (000)

  05/16/95 - Release (001)
           - Added FEnable3D field to store whether 3D drawing should be used
               or not depending on running Windows version.
           - Added check for iconic state before performing 3D drawing.
           - Modified caption drawing to left align caption if it is too wide
               for the available area, ala windows.

  07/19/95 - Release (002)
           - Added WM_SetText handler to correct redraw problem on forms with
               no menu when caption is changed.
}


interface

uses
  Messages, WinTypes,
  Classes, Controls, Forms;


const
  CaptionH_STD = 20;
  MenuH_STD    = 18;


type
  TForm3D_NCPaintMode =
    (
    NCPaint_All,
    NCPaint_Activate,
    NCPaint_Deactivate
    );

type
  TForm3D = class(TForm)
  private
    FEnable3D     : Boolean;  { Flag to identify if can use 3D effects }
    FSysMenuW     : Integer;  { Width of system menu,     0 if no sysmenu }
    FMinMaxW      : Integer;  { Width of min/max buttons, 0 if no min/max btns }
    FAllowResize  : Boolean;
    { Private procedures }
    procedure NCPaint3D(const Mode: TForm3D_NCPaintMode);
    procedure ComputeNonClientDimensions;
    function ScrollBarVisible
      (
      const Code    : Word;  { SB_VERT or SB_HORZ }
      const WndRect : TRect
      ): Boolean;
    { Message Handlers }
    procedure WMNCHitTest (var Msg: TWMNCHitTest);  message WM_NCHitTest;
    procedure WMSetText   (var Msg: TWMSetText);    message WM_SetText;
    procedure WMNCPaint   (var Msg: TWMNCPaint);    message WM_NCPaint;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCActivate;
  protected
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    { Properties }
    property AllowResize: Boolean
             read FAllowResize
             write FAllowResize
             default False;
  end;


implementation


uses
  WinProcs,
  SysUtils, Graphics,
  SysMet;


function TForm3D.ScrollBarVisible
  (
  const Code    : Word;  { SB_VERT or SB_HORZ }
  const WndRect : TRect
  ): Boolean;
var
  PtInScroll : TPoint;
  HVis       : Boolean;
begin
  Result := False;

  with  WndRect, SysMetrics  do
    begin
    { Determine if Horz scroll bar is visible. Need this for both horz and }
    {   vert scroll bars. }
    { Two checks need to be satisfied, Style identifies scroll bar and }
    {   windows recognizes HitTest in scroll bar. }
    { Hit Test check is required because there are cases when the window }
    {   gets very small that windows decides not to draw the scroll bars }
    {   even though they exist. }
    PtInScroll := Point(Left + Frame.cx + 1, Bottom - Frame.cy - 1);
    HVis := ( ((GetWindowLong(Handle, GWL_STYLE) and WS_HSCROLL) <> 0) and
              (Perform(WM_NCHITTEST, 0, LongInt(PtInScroll)) = HTHSCROLL) );

    if ( Code = SB_HORZ ) then
      begin  { Done, return result computed above }
      Result := HVis;
      end
    else
      begin  { Perform same procedure as above for vertical }
      PtInScroll := Point(Right - Frame.cx - 1, Bottom - Frame.cy - 1);
      if ( HVis ) then Dec(PtInScroll.y, HScrollBtn.cy);
      Result := ( ((GetWindowLong(Handle, GWL_STYLE) and WS_VSCROLL) <> 0) and
                  (Perform(WM_NCHITTEST, 0, LongInt(PtInScroll)) = HTVSCROLL) );
      end;
    end;
end;



constructor TForm3D.Create
  (
  AOwner: TComponent
  );
begin
  inherited Create(AOwner);

  { Set property defaults }
  FAllowResize  := False;
end;


{
  CreateWnd is overriden so we can force certain properties before
    the window is created, and compute some parameters needed to
    do the 3D non-client drawing.
}
procedure TForm3D.CreateWnd;
var
  AdjustHeight : Integer;
  Version      : TWindowsVersion;
  VerMajor     : Word;
  VerMinor     : Word;
begin
  { Border Style must be bsSizeable }
  BorderStyle := bsSizeable;

  { Compute height adjustments for font caption and menu.      }
  { In large fonts video modes the client area would otherwise }
  {   be reduced. }
  AdjustHeight := 0;
  with  SysMetrics  do
    begin
    Inc(AdjustHeight, CaptionH - CaptionH_STD);
    { Note: Only adjusts for a single line menu bar }
    if ( Menu <> nil ) then Inc(AdjustHeight, MenuH - MenuH_STD);
    end;

  { Let Form create }
  inherited CreateWnd;

  { Enforce the height adjustment }
  Height := Height + AdjustHeight;

  { 3D Drawing requires Win 3.x default behavior. }
  GetWindowsVersion(Version, VerMajor, VerMinor);
  FEnable3D := ( (VerMajor = 3) and (VerMinor = 10) );

  { Precompute dimensions of key non-client areas for later use }
  {   in drawing the 3D effects. }
  if ( FEnable3D ) then ComputeNonClientDimensions;
end;


{
ComputeNonClientDimensions precomputes some dimensions of non-client items
  to avoid doing it repeatedly during painting.
}
procedure TForm3D.ComputeNonClientDimensions;

  { We'd like to use the SM_CXSIZE system metrics value for the size of icons }
  {  in the title bar but it is NOT correct for some video drivers/modes }
  function BitmapWidth(const BM_ID: Integer): Integer;
  var
    BM     : THandle;
    BMInfo : WinTypes.TBitmap;
  begin
    BM := LoadBitmap(0, MakeIntResource(BM_ID));
    try
      GetObject(BM, SizeOf(BMInfo), @BMInfo);
      Result := BMInfo.bmWidth;
    finally
      DeleteObject(BM);
    end;
  end;

begin
  FSysMenuW := 0;
  if ( biSystemMenu in BorderIcons ) then
    begin
    { Note: Close bitmap contains 2 bitmaps, app close and MDI child close }
    Inc(FSysMenuW, BitmapWidth(OBM_CLOSE) div 2);
    end;

  FMinMaxW := 0;
  if ( biMinimize in BorderIcons ) then
    begin
    Inc(FMinMaxW, BitmapWidth(OBM_REDUCE));
    end;
  if ( biMaximize in BorderIcons ) then
    begin
    Inc(FMinMaxW, BitmapWidth(OBM_ZOOM));
    end;
end;


{
NCPaint3D handles the 3D specific painting for the form.
}
procedure TForm3D.NCPaint3D
  (
  const Mode: TForm3D_NCPaintMode
  );
var
  WndRect     : TRect;
  ClientRect  : TRect;
  ClientH     : Integer;
  ScrollH     : Integer;
  DC          : HDC;
  NCCanvas    : TCanvas;
  Extra       : Integer;
  CaptionRect : TRect;
  CaptionPt   : TPoint;
  TM          : TTextMetric;
  CaptionBuf  : array[0..255] of Char;
begin
  { Get window rect }
  WinProcs.GetWindowRect(Handle, WndRect);
  { Need to know if horz scroll bar present }
  ScrollH := 0;
  if ( ScrollBarVisible(SB_HORZ, WndRect) ) then
    begin
    ScrollH := SysMetrics.HScrollBtn.cy - 1;
    end;
  { Convert window rect to (0, 0) origin }
  with  WndRect  do
    begin
    Right  := Right - Left;
    Left   := 0;
    Bottom := Bottom - Top;
    Top    := 0;
    end;
  WinProcs.GetClientRect(Handle, ClientRect);
  ClientH := ClientRect.Bottom - ClientRect.Top;
  if ( 0 < ClientH ) then Inc(ClientH);

  { Get a Window DC and wrap it in a Delphi Canvas }
  DC       := GetWindowDC(Self.Handle);
  NCCanvas := TCanvas.Create;
  NCCanvas.Handle := DC;
  try
    with NCCanvas, WndRect, SysMetrics do
      begin
      if ( Mode = NCPaint_All ) then
        begin
        { Draw Left and Top edges of window frame, outer }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Left,  Bottom - 1),
                   Point(Left,  Top),
                   Point(Right, Top) ]);
        { Draw Bottom and Right edges of window frame, outer }
        Pen.Color := clWindowFrame;
        PolyLine([ Point(Left,  Bottom - 1),
                   Point(Right - 1, Bottom - 1),
                   Point(Right - 1, Top - 1) ]);
        { Draw Left and Top edges of window frame, 1-pixel in }
        Pen.Color := clBtnHighlight;
        PolyLine([ Point(Left  + 1, Bottom - 2),
                   Point(Left  + 1, Top    + 1),
                   Point(Right - 1, Top    + 1) ]);
        { Draw Right and Bottom edges of window frame, 1-pixel in }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Left  + 1, Bottom - 2),
                   Point(Right - 2, Bottom - 2),
                   Point(Right - 2, Top) ]);

        { Fill Remainder of Sizing border }
        Pen.Color := clBtnFace;
        for Extra := 2 to (Frame.cx - 1) do
          begin
          Brush.Color := clBtnFace;
          FrameRect(Rect(Left + Extra, Top + Extra,
                         Right - Extra, Bottom - Extra));
          end;

        { Draw Left and Top Edge of Caption Area }
        Pen.Color := clBtnShadow;
        PolyLine([ Point(Frame.cx - 1, Bottom - 1 - Frame.cy - ClientH - ScrollH),
                   Point(Frame.cx - 1, Frame.cy - 1),
                   Point(Right - Frame.cx, Frame.cy - 1) ]);
        { Draw Bottom and Right Edge of Caption Area }
        Pen.Color := clBtnHighlight;
        PolyLine([ Point(Frame.cx - 1,     Bottom - Frame.cy - ClientH - ScrollH),
                   Point(Right - Frame.cx, Bottom - Frame.cy - ClientH - ScrollH),
                   Point(Right - Frame.cx, Frame.cy - 1) ]);
        end;

      { Draw Caption }
      CaptionRect := Rect(Frame.cx + FSysMenuW + 1, Frame.cy,
                          Right - Frame.cx - FMinMaxW,
                          Frame.cy - 1 + CaptionH - 1);
      if ( (Mode = NCPaint_Activate) or
           ((Mode = NCPaint_All) and (GetActiveWindow = Self.Handle)) ) then
        begin  { Need 'Active' Caption }
        Brush.Color := clActiveCaption;
        Font.Color  := clCaptionText;
        end
      else
        begin  { Need 'InActive' Caption }
        Brush.Color := clInactiveCaption;
        Font.Color  := clInactiveCaptionText;
        end;
      FillRect(CaptionRect);
      with  CaptionRect  do
        begin
        { Assume center aligned }
        SetTextAlign(DC, TA_CENTER or TA_TOP);
        GetTextMetrics(DC, TM);
        CaptionPt := Point((Left + Right) div 2,
                           Top + ((CaptionH - 1) - TM.tmHeight) div 2);
        if ( (Right - Left) < TextWidth(Caption) ) then
          begin { Switch caption to left align to mimic windows }
          SetTextAlign(DC, TA_LEFT or TA_TOP);
          CaptionPt.X := Left + 1;
          end;
        TextRect(CaptionRect, CaptionPt.X, CaptionPt.Y, Caption);
        end;
      end;
  finally
    NCCanvas.Free;
    ReleaseDC(Handle, DC);
  end; { try-finally }
end;


{
WMNCHitTest handles the WM_NCHITTEST message.
Modifies sizing hit codes to support fixed size windows.
}
procedure TForm3D.WMNCHitTest
  (
  var Msg: TWMNCHitTest
  );
var
  HitCode : LongInt;
begin
  inherited;
  HitCode := Msg.Result;

  { Lets resurrect the size corner }
  if ( HitCode = HTSIZE ) then HitCode := HTBOTTOMRIGHT;

  if ( not AllowResize ) then
    begin
    if ( (HitCode = HTLEFT)     or (HitCode = HTRIGHT)      or
         (HitCode = HTTOP)      or (HitCode = HTBOTTOM)     or
         (HitCode = HTTOPLEFT)  or (HitCode = HTBOTTOMLEFT) or
         (HitCode = HTTOPRIGHT) or (HitCode = HTBOTTOMRIGHT) ) then
      begin
      HitCode := HTNOWHERE;
      end;
    end;

  Msg.Result := HitCode;
end;


{
WMNCPaint handles WM_NCPAINT message.
Calls default handler to paint non-client areas that have standard appearance.
Calls NCPaint3D to paint modified non-client areas
NOTE: Uses undocumented aspect of WM_NCPAINT message which allows a clipping
      region handle to be passed in the wParam of the message.
      This is used to avoid seeing the standard non-client areas flash before
      they are repainted by the 3D code.
      Ref. Undocumented Windows pg. 527, Thanks Andrew.
}
procedure TForm3D.WMNCPaint
  (
  var Msg: TWMNCPaint
  );
var
  WndRect    : TRect;
  ClientRect : TRect;
  ClientH    : Integer;
  ScrollH    : Integer;
  ClipRect   : TRect;
  ClipRgn    : THandle;
  HScrollVis : Boolean;
  VScrollVis : Boolean;
begin
  if ( FEnable3D and (not IsIconic(Handle)) ) then
    begin
    { Let Windows draw the non-client areas that will not change }
    { Form props for window pos and size incorrect during resize here. }
    { Get Position directly from windows }
    WinProcs.GetWindowRect(Handle, WndRect);
    WinProcs.GetClientRect(Handle, ClientRect);
    ClientH := ClientRect.Bottom - ClientRect.Top;
    if ( 0 < ClientH ) then Inc(ClientH);

    HScrollVis := ScrollBarVisible(SB_HORZ, WndRect);
    VScrollVis := ScrollBarVisible(SB_VERT, WndRect);

    ScrollH := 0;
    if ( HScrollVis ) then ScrollH := SysMetrics.HScrollBtn.cy - 1;

    with  WndRect, SysMetrics  do
      begin
      { System Menu }
      if ( biSystemMenu in BorderIcons ) then
        begin
        ClipRect := Rect(Left + Frame.cx, Top + Frame.cy,
                         Left + Frame.cx + TitleBitmap.cx + 1,
                         Top  + Frame.cy + TitleBitmap.cy);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      { Min/Max buttons }
      if ( 0 < FMinMaxW ) then
        begin
        ClipRect := Rect(Right - Frame.cx - FMinMaxW, Top  + Frame.cy,
                         Right - Frame.cx, Top + Frame.cy + TitleBitmap.cy);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      { Menubar }
      if ( Menu <> nil ) then
        begin
        ClipRect := Rect(Left + Frame.cx, Top + Frame.cy + CaptionH - Border.cy - 1,
                         Right - Frame.cx, Bottom - Frame.cy - ClientH - ScrollH);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      end;

    { Paint 3-D parts of nonclient area in 3-D style }
    NCPaint3D(NCPaint_All);

    { Now let windows paint scroll bars. Need to wait until here because scroll }
    {   bars take advantage of normal borders for their outer edges and they    }
    {   our trounced in NCPaint3D. }
    with  WndRect, SysMetrics  do
      begin
      if ( HScrollVis ) then
        begin { Let Windows draw horz scroll bar }
        ClipRect := Rect(Left  + (Frame.cx - 1), Bottom - (Frame.cy - 1) - HScrollBtn.cy,
                         Right - (Frame.cx - 1), Bottom - (Frame.cy - 1));
        if ( VScrollVis ) then Dec(ClipRect.Right, VScrollBtn.cx - 1);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      if ( VScrollVis ) then
        begin { Let Windows draw vert scroll bar }
        ClipRect := Rect(Right - (Frame.cx - 1) - VScrollBtn.cx, Bottom - Frame.cy - ClientH - ScrollH,
                         Right - (Frame.cx - 1),                 Bottom - (Frame.cy - 1));
        if ( HScrollVis ) then Dec(ClipRect.Bottom, HScrollBtn.cy - 1);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      if ( HScrollVis and VScrollVis ) then
        begin { Let Windows draw little box in corner }
        ClipRect := Rect(Right - (Frame.cx - 1) - (VScrollBtn.cx - 1),
                         Bottom - (Frame.cy - 1) - (HScrollBtn.cy - 1),
                         Right - (Frame.cx - 1) - 1, Bottom - (Frame.cy - 1) - 1);
        ClipRgn := CreateRectRgnIndirect(ClipRect);
        TMessage(Msg).wParam := ClipRgn;
        (self as TWinControl).DefaultHandler(Msg);
        DeleteObject(ClipRgn);
        end;
      end;
    Msg.Result := 0;
    end
  else
    begin
    { Use whatever behavior is standard for this system }
    DefaultHandler(Msg);
    end;
end;


{
WMNCActivate handles the WM_NCACTIVATE message.
Calls NCPaint3D to repaint the caption.
Can NOT let windows have this message or it will trash our 3D borders.
}
procedure TForm3D.WMNCActivate
  (
  var Msg: TWMNCActivate
  );
begin
  if ( FEnable3D and (not IsIconic(Handle)) ) then
    begin
    if ( Msg.Active ) then
      NCPaint3D(NCPaint_Activate)
    else
      NCPaint3D(NCPaint_Deactivate);

    Msg.Result := 1;
    end
  else
    begin
    DefaultHandler(Msg);
    end;
end;


procedure TForm3D.WMSetText
  (
  var Msg : TWMSetText
  );
begin
  { Got to let this one through so caption updated }
  inherited;

  if ( Menu = nil ) then
    begin
    { Repaint the sucker }
    NCPaint3D(NCPaint_All);
    end;
end;


end.