Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/D/WIDGETS.ZIP/WIDGET.PAS

Pascal/Delphi Source File | 1998-07-25 | 20.5 KB | 725 lines

(*

                     TWidget: A Title Bar Button
                     ~~~~~~~~~~~~~~~~~~~~~~~~~~~

               Copyright 1998 by Robert R. Marsh, SJ
          and the British Province of the Society of Jesus

                           [e-mail]
                 http://home.sprynet.com/sprynet/rrm

   What another title bar button?! Yes ... but one that does the job
   simply and cleanly.

   A Widget is drawn using the same technique windows itself uses to
   draw its own frame buttons so they match exactly. The glyph of the
   Widget comes from a truetype font. Windows uses the font Marlett for
   its own glyphs but you can use any font you like. You can set the
   glyph's color, the gap between it and the windows buttons, and even
   give it a Hint. A Widget component editor makes choosing the glyph
   very easy.

   Widgets are meant to adapt gracefully to any kind of window, even
   coping with changes in caption size at run-time. You can have as many
   Widgets in operation at any one time as you like. They are even
   visible at design-time!

   The Widget components are released as freeware with no promise
   expressed or implied about their suitability for any purpose. Use
   them at your own risk. Please let me know though of any problems you
   encounter.

   Parts of this code are inspired by the work of other authors whom I
   wish to acknowledge gratefully:

        Brendan De Lumpa,
        Sean Hsieh
        The Programmers' Guild Guys


*)

(*
   This version (7/25/1998) has been enhanced to cope with forms with menus
   ( thanks to Matt Hamilton for pointing out the problem ) and support has
   been added for painting a bitmap instead of a font glyph ( thanks to John
   Knipper ). There is now a published Image property. If no image is assigned
   the glyph is drawn as before but if an image has been chosen it is painted.
   The offset properties still apply. The WidgetEditor has been slightly
   enhanced to let you choose the offset for images as well as glyphs but the
   image property should be assigned via the Object Inspector. More work is
   needed here!
   There is now a public read-only WidgetRect property giving the location of
   the widget in case you need to respond to a widget click in a way that needs
   such information.
   Also at John Knipper's suggestion TWidget now has a published PopupMenu
   property. When this is set the menu pops up instead of the widget triggering
   the OnClick event handler.
   I've also changed the hint windows behavior to produce more conventional single-
   line hints.
*)

unit widget;

interface

uses
  Windows,
  Messages,
  Classes,
  Graphics,
  Controls,
  ExtCtrls,
  Menus;

type
  TWidgetHint = class
  private
    FHintWindow: THintWindow;
    FHint: string;
    FStarted: boolean;
    FShowing: boolean;
    FXPos: integer;
    FYPos: integer;
    Timer: TTimer;
  protected
    procedure ShowWindow(Sender: TObject);
    procedure HideWindow(Sender: TObject);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    property Hint: string read FHint write FHint;
    property Started: boolean read FStarted;
    property XPos: integer read FXPos write FXPos;
    property YPos: integer read FYPos write FYPos;
  end;

type
  TWidget = class(TComponent)
  private
    OldWndProc: TFarProc;
    NewWndProc: TFarProc;
    FEnabled: boolean;
    FFont: TFont;
    FImage: TBitmap;
    FGap: integer;
    FGlyph: char;
    FHint: string;
    FShowHint: boolean;
    FOffsetLeft: integer;
    FOffsetTop: integer;
    FPopupMenu: TPopupMenu;
    FVisible: boolean;
    FOnClick: TNotifyEvent;
    FWidgetRect: TRect;
    OldFont: TFont;
    Pressed: boolean;
    DrawPressed: boolean;
    HintWindow: TWidgetHint;
    WidgetNumber: integer;
    RestoreTimer: TTimer;
    procedure NewWndMethod(var msg: TMessage);
    procedure RestoreHooks(Sender: TObject);
  protected
    procedure Click;
    procedure CalculateWidgetArea;
    procedure DrawWidget;
    procedure SetEnabled(value: boolean);
    procedure SetFont(Value: TFont);
    procedure SetGap(Value: integer);
    procedure SetGlyph(Value: char);
    procedure SetImage(Value: TBitmap);
    procedure SetOffsetLeft(value: integer);
    procedure SetOffsetTop(value: integer);
    procedure SetVisible(value: boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property WidgetRect: TRect read FWidgetRect;
  published
    property Enabled: boolean read FEnabled write SetEnabled default true;
    property Font: TFont read FFont write SetFont;
    property Gap: integer read FGap write SetGap default 2;
    property Glyph: char read FGlyph write SetGlyph;
    property Hint: string read FHint write FHint;
    property Image: TBitmap read FImage write SetImage;
    property OffsetLeft: integer read FOffsetLeft write SetOffsetLeft;
    property OffsetTop: integer read FOffsetTop write SetOffsetTop;
    property PopupMenu: TPopupMenu read FPopupmenu write FPopupMenu;
    property ShowHint: boolean read FShowHint write FShowHint default false;
    property Visible: boolean read FVisible write SetVisible default true;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

implementation

uses
  SysUtils,
  Forms;

{ TWidgetHint }

// provides a hint for the widget

constructor TWidgetHint.Create;
begin
  inherited Create;
  FHintWindow := THintWindow.Create(nil);
  Timer := TTimer.Create(nil);
  Timer.Enabled := false;
  FHintWindow.Brush.Color := Application.HintColor;
  FStarted := false;
  FShowing := false;
end;

destructor TWidgetHint.Destroy;
begin
  Timer.Free;
  FHintWindow.Free;
  inherited Destroy;
end;

procedure TWidgetHint.Start;
begin
  Timer.Interval := Application.HintPause;
  Timer.OnTimer := ShowWindow;
  Timer.Enabled := true;
  FStarted := true;
  FShowing := false;
end;

procedure TWidgetHint.Stop;
begin
  Timer.Enabled := false;
  if FShowing then
    FHintWindow.ReleaseHandle;
  FStarted := false;
  FShowing := false;
end;

// for displaying

function GetCursorHeightMargin: integer;
var
  IconInfo: TIconInfo;
  BitmapInfoSize: {$IFDEF VER120}cardinal{$ELSE}integer{$ENDIF};
  BitmapBitsSize: {$IFDEF VER120}cardinal{$ELSE}integer{$ENDIF};
  Bitmap: PBitmapInfoHeader;
  Bits: pointer;
  BytesPerScanline, ImageSize: integer;

  function FindScanline(Source: pointer; MaxLen: Cardinal;
    Value: Cardinal): Cardinal; assembler;
  asm
              PUSH    ECX
              MOV     ECX,EDX
              MOV     EDX,EDI
              MOV     EDI,EAX
              POP     EAX
              REPE    SCASB
              MOV     EAX,ECX
              MOV     EDI,EDX
  end;

begin
  { Default value is entire icon height }
  Result := GetSystemMetrics(SM_CYCURSOR);
  if GetIconInfo(GetCursor, IconInfo) then
  try
    GetDIBSizes(IconInfo.hbmMask, BitmapInfoSize, BitmapBitsSize);
    Bitmap := AllocMem(BitmapInfoSize + BitmapBitsSize);
    try
      Bits := pointer(longint(Bitmap) + BitmapInfoSize);
      if GetDIB(IconInfo.hbmMask, 0, Bitmap^, Bits^) and
        (Bitmap^.biBitCount = 1) then
      begin
          { Point Bits to the end of this bottom-up bitmap }
        with Bitmap^ do
        begin
          BytesPerScanline := ((biWidth * biBitCount + 31) and not 31) div 8;
          ImageSize := biWidth * BytesPerScanline;
          Bits := pointer(integer(Bits) + BitmapBitsSize - ImageSize);
            { Use the width to determine the height since another mask bitmap
              may immediately follow }
          Result := FindScanline(Bits, ImageSize, $FF);
            { In case the and mask is blank, look for an empty scanline in the
              xor mask. }
          if (Result = 0) and (biHeight >= 2 * biWidth) then
            Result := FindScanline(pointer(integer(Bits) - ImageSize),
              ImageSize, $00);
          Result := Result div BytesPerScanline;
        end;
        dec(Result, IconInfo.yHotSpot);
      end;
    finally
      FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
    end;
  finally
    if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor);
    if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask);
  end;
end;

procedure TWidgetHint.ShowWindow(Sender: TObject);
var
  R: TRect;
begin
  Timer.Enabled := false;
  if Hint = '' then
    Exit;
  // we need to calculate the size for the hint window
  r := Rect(0, 0, Length(Hint), 0);
  DrawText(FHintWindow.Canvas.Handle, PChar(Hint), -1, r, DT_CALCRECT or DT_LEFT or DT_NOPREFIX);
  Inc(r.Right, 6);
  Inc(r.Bottom, 2);
  // add the height of the cursor
  OffsetRect(R, XPos, YPos + GetCursorHeightMargin);
  FHintWindow.ActivateHint(R, Hint);
  Timer.Interval := Application.HintHidePause;
  Timer.OnTimer := HideWindow;
  Timer.Enabled := true;
  FShowing := true;
end;

procedure TWidgetHint.HideWindow(Sender: TObject);
begin
  Stop;
end;

{ TWidget }

constructor TWidget.Create(AOwner: TComponent);
var
  i: integer;
begin
  // ensure owner is a form
  if (AOwner = nil) or not (AOwner is TForm) then
    raise Exception.Create('A Widget must be owned by a form');
  // first Widget is zero, second is one, etc.
  WidgetNumber := 0;
  for i := 1 to AOwner.ComponentCount do
    if AOwner.Components[i - 1] is TWidget then
      inc(WidgetNumber);
  inherited Create(AOwner);
  FEnabled := true;
  FFont := TFont.Create;
  FFont.Name := 'Marlett';
  FFont.Color := clWindowText;
  FFont.Style := [];
  FGap := 2; // default spacing
  FGlyph := 'v'; // a double up/down arrow in Marlett
  FVisible := true;
  OldFont := TFont.Create;
  HintWindow := TWidgetHint.Create;
  FImage := TBitMap.Create;
  // subclass the owner to catch all its messages
  NewWndProc := MakeObjectInstance(NewWndMethod);
  OldWndProc := pointer(SetWindowLong((AOwner as TForm).Handle, gwl_WndProc, longint(NewWndProc)));
  CalculateWidgetArea;
  DrawWidget;
end;

destructor TWidget.Destroy;
begin
  if Assigned(NewWndProc) and Assigned(Owner) then
  begin
    SetWindowLong((Owner as TForm).Handle, gwl_WndProc, longint(OldWndProc));
    FreeObjectInstance(NewWndProc);
  end;
  HintWindow.Free;
  FFont.Free;
  OldFont.Free;
  FImage.Free;
  inherited Destroy;
end;

// called when the form is being recreated during a borderstyle
// change (for exmaple) -- rehooks the message trap

procedure TWidget.RestoreHooks(Sender: TObject);
begin
  RestoreTimer.Enabled := false;
  RestoreTimer.Free;
  OldWndProc := pointer(SetWindowLong((Owner as TForm).Handle, gwl_WndProc, longint(NewWndProc)));
  CalculateWidgetArea;
  DrawWidget;
end;

const
  wm_widgetupdate = wm_user + 1; // "widget draw thyself"

// This does all the work of handling the owner forms
// messages. What it doesn't handle it passes on down
// the chain of handlers.

procedure TWidget.NewWndMethod(var msg: TMessage);

  // pass the message on ...

  procedure DefHandler;
  begin
    msg.Result := CallWindowProc(OldWndProc, (Owner as TForm).Handle, msg.Msg, msg.wParam, msg.lParam);
  end;

  // is the 'message' location within the widget?

  function InArea(InClient: boolean): boolean;
  var
    p: TPoint;
  begin
    p.X := Msg.lParamLo;
    p.Y := smallint(Msg.lParamHi);
    if not InClient then
      ScreenToClient(TForm(Owner).Handle, p);
    inc(p.X, 4);
    inc(p.Y, (8 + FWidgetRect.Bottom - FWidgetRect.Top));
    if ((Owner as TForm).Menu <> nil) and ((Owner as TForm).FormStyle <> fsMDIChild) then
      inc(p.Y, GetSystemMetrics(SM_CYMENU));
    Result := PtInRect(FWidgetRect, p);
  end;

begin
  case msg.Msg of
    wm_ncpaint, wm_ncactivate:
      begin
        DefHandler;
        // then post a message to yourself to redraw when possible
        PostMessage((Owner as TForm).Handle, wm_widgetupdate, 0, WidgetNumber);
      end;
    wm_widgetupdate:
      begin
        if msg.lParam = WidgetNumber then
          DrawWidget
        else
          DefHandler;
      end;
    wm_nclbuttondown, wm_nclbuttondblclk:
      begin
        if InArea(false) and Visible then
          // going down on the widget
        begin
          if Enabled then
          begin
            SetCapture(TForm(Owner).Handle);
            DrawPressed := true;
            Pressed := true;
            DrawWidget;
          end;
          // we're done
          Msg.Result := 1;
        end
        else
          DefHandler;
      end;
    wm_mousemove:
      begin
        // cancel any hint
        if HintWindow.Started then
          HintWindow.Stop;
        if Pressed then
          // the widget has been pressed
        begin
          if not InArea(true) then
            // we're outside the widget
          begin
            // so show it 'unpressed'
            if DrawPressed then
            begin
              DrawPressed := false;
              DrawWidget;
            end;
          end
          else
            // we're inside the widget
          begin
            if not DrawPressed then
              // make it draw 'pressed' again
            begin
              DrawPressed := true;
              DrawWidget;
            end;
          end;
          msg.Result := 1;
        end
        else
          DefHandler;
      end;
    wm_ncmousemove:
      begin
        if InArea(false) then
          // we're over the widget
        begin
          if not HintWindow.Started and ShowHint and Visible and Enabled then
            // initiate the hint
          begin
            HintWindow.Hint := Hint;
            HintWindow.XPos := TWMNCMouseMove(msg).XCursor;
            HintWindow.YPos := TWMNCMouseMove(msg).YCursor;
            HintWindow.Start;
          end;
        end
        else
        begin
          // cancel any hint
          if HintWindow.Started then
            HintWindow.Stop;
        end;
        // pass it along
        DefHandler;
      end;
    wm_lbuttonup, wm_lbuttondblclk:
      begin
        DrawPressed := false;
        if Pressed then
        begin
          if InArea(true) then
          begin
            Click;
          end;
          DrawWidget;
          msg.Result := 1;
        end
        else
          DefHandler;
        Pressed := false;
        ReleaseCapture;
      end;
    wm_size, wm_windowposchanged, wm_settingchange, wm_stylechanged, wm_setfocus:
      begin
        // pass it along
        DefHandler;
        // and on the way back get the caption to redraw
        CalculateWidgetArea;
        DrawWidget;
      end;
    wm_destroy:
      begin
        if not (csDestroying in ComponentState) then
        begin
          // the form is being destroyed but only to recreate it
          // we need to re hook everything in a short while
          RestoreTimer := TTimer.Create(Application);
          with RestoreTimer do
          begin
            OnTimer := RestoreHooks;
            Interval := 1;
            Enabled := true;
          end;
        end;
        DefHandler;
      end;
  else
    DefHandler;
  end;
end;

procedure TWidget.Click;
begin
  if Enabled then
    if Assigned(FPopupMenu) then
    begin
      FPopupmenu.Popup(FWidgetRect.Left+(Owner as TForm).Left, FWidgetRect.Bottom+(Owner as TForm).Top)
    end
    else
      if Assigned(FOnClick) then
        FOnClick(Self);
end;

// work out exactly where to put the widget

procedure TWidget.CalculateWidgetArea;
var
  xframe: integer;
  yFrame: integer;
  xsize: integer;
  ysize: integer;
  Icons: TBorderIcons;
  Style: TFormBorderStyle;
begin
  if (Owner as TForm) = nil then
    exit;
  with (Owner as TForm) do
  begin
    // it will be different at design time
    if (csDesigning in ComponentState) then
    begin
      Icons := [biSystemMenu, biMinimize, biMaximize];
      Style := bsSizeable;
    end
    else
    begin
      Icons := BorderIcons;
      Style := BorderStyle;
    end;
    if Style in [bsSizeToolWin, bsToolWindow] then
    begin
      if Style = bsToolWindow then
        xframe := GetSystemMetrics(SM_CXFIXEDFRAME)
      else
        xframe := GetSystemMetrics(SM_CXSIZEFRAME);
      if biSystemMenu in Icons then
        inc(xframe, GetSystemMetrics(SM_CXSMSIZE));
      if Style = bsToolWindow then
        yframe := GetSystemMetrics(SM_CYFIXEDFRAME)
      else
        yframe := GetSystemMetrics(SM_CYSIZEFRAME);
      ysize := GetSystemMetrics(SM_CYSMSIZE);
      xsize := GetSystemMetrics(SM_CXSMSIZE);
    end
    else
    begin
      if Style in [bsSingle, bsSizeable, bsDialog] then
      begin
        if Style = bsSingle then
          xframe := GetSystemMetrics(SM_CYFIXEDFRAME)
        else
          xframe := GetSystemMetrics(SM_CXSIZEFRAME);
        if biSystemMenu in Icons then
        begin
          inc(xframe, GetSystemMetrics(SM_CXSIZE));
          if (Style <> bsDialog) and (Icons * [biMinimize, biMaximize] <> []) then
            inc(xframe, GetSystemMetrics(SM_CXSIZE) * 2)
          else
            if biHelp in Icons then
              inc(xframe, GetSystemMetrics(SM_CXSIZE));
        end;
        if Style in [bsSingle, bsDialog] then
          yframe := GetSystemMetrics(SM_CYFIXEDFRAME)
        else
          yframe := GetSystemMetrics(SM_CYSIZEFRAME);
        ysize := GetSystemMetrics(SM_CYSIZE);
        xsize := GetSystemMetrics(SM_CXSIZE);
      end;
    end;
    // each successive Widget is a little further left
    inc(xframe, WidgetNumber * (Gap - 2 + xsize));
    // finally we calculate the size and position of the widget
    FWidgetRect := Bounds(Width - xFrame - xSize + 4 - Gap, yFrame + 2, xSize - 2, ySize - 4);
  end;
end;

procedure TWidget.DrawWidget;
var
  WidgetState: integer;
  R: TRect;
  RB: TRect;
begin
  if ((Owner as TForm) = nil) or not Visible then
    exit;
  with (Owner as TForm) do
  begin
    //Get the handle to the canvas
    Canvas.Handle := GetWindowDC(Handle);
    try
      // save the font
      OldFont.Assign(Canvas.Font);
      // use the widget's font
      Canvas.Font.Assign(FFont);
      try
        Canvas.Brush.Color := clBtnFace;
        SetBkMode(Canvas.Handle, TRANSPARENT);
        WidgetState := DFCS_BUTTONPUSH;
        if not FEnabled then
        begin
          WidgetState := WidgetState or DFCS_INACTIVE;
          DrawPressed := false;
          Canvas.Font.Color := clGrayText;
        end;
        if DrawPressed then
          WidgetState := WidgetState or DFCS_PUSHED;
        // this is how windows draws its own frame buttons
        DrawFrameControl(Canvas.Handle, FWidgetRect, DFC_BUTTON, WidgetState);
        // define a smaller area to put the glyph in
        R := FWidgetRect;
        InflateRect(R, -2, -2);
        if DrawPressed then
          OffsetRect(R, 1, 1);
        OffsetRect(R, OffsetLeft, OffsetTop);
        if FImage.Empty then
        begin
          // choose a font size to fit
          Canvas.Font.Height := (R.Top - R.Bottom - 1);
          DrawText(Canvas.Handle, pchar(string(FGlyph)), 1, R, DT_CENTER or DT_VCENTER or DT_NOCLIP);
        end
        else
        begin
          RB := FImage.Canvas.ClipRect;
          Canvas.BrushCopy(R, FImage, RB, FImage.TransparentColor);
        end;
      finally
        Canvas.Font.Assign(OldFont);
      end;
    finally
      ReleaseDC(Handle, Canvas.Handle);
      Canvas.Handle := 0;
    end;
  end;
end;

procedure TWidget.SetEnabled(Value: boolean);
begin
  if FEnabled <> value then
  begin
    FEnabled := value;
    CalculateWidgetArea;
    DrawWidget;
  end;
end;

procedure TWidget.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  CalculateWidgetArea;
  DrawWidget;
end;

procedure TWidget.SetGap(Value: integer);
begin
  FGap := Value;
  CalculateWidgetArea;
  DrawWidget;
end;

procedure TWidget.SetGlyph(Value: char);
begin
  FGlyph := Value;
  CalculateWidgetArea;
  DrawWidget;
end;

procedure TWidget.SetImage(Value: TBitmap);
begin
  FImage.Assign(Value);
  DrawWidget;
end;

procedure TWidget.SetOffsetLeft(value: integer);
begin
  FOffsetLeft := value;
  CalculateWidgetArea;
  DrawWidget;
end;

procedure TWidget.SetOffsetTop(value: integer);
begin
  FOffsetTop := value;
  CalculateWidgetArea;
  DrawWidget;
end;

procedure TWidget.SetVisible(Value: boolean);
begin
  if FVisible <> value then
  begin
    FVisible := value;
    CalculateWidgetArea;
    DrawWidget;
  end;
end;

end.