Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PCTV3N3.ZIP/MDITOOL.ZIP/TOOLBAR.ZIP/TOOLBAR.PAS

Pascal/Delphi Source File | 1992-05-29 | 13.8 KB | 517 lines

{************************************************}
{                                                }
{   Turbo Pascal for Windows                     }
{   Demo program                                 }
{   Copyright (c) 1992 by Borland International  }
{                                                }
{   Author: Danny Thorpe, QA Engineer            }
{           Pascal Compiler Group                }
{                                                }
{************************************************}

unit Toolbar;

interface

{$R Toolbar.res}

uses Winprocs, Wintypes, WObjects, Strings;

const

  am_SetParentClientRect = wm_User + 120;

type


  PToolButton = ^TToolButton;
  TToolButton = object(TObject)
    Parent: PWindowsObject;
    bmNormal, bmPressed, bmGlyph: HBitmap;
    brGraying: HBrush;
    Command: Word;
    Capturing, IsPressed, IsEnabled: Boolean;
    R: TRect;
    GlyphSize: TPoint;
    CapDC, MemDC: HDC;
    constructor Init(AParent: PWindowsObject;
                     X, Y: Integer;
                     ACommand: Word;
                     BitmapName: PChar);
    destructor Done; virtual;
    procedure Enable(NewState: Boolean);
    function  GetWidth: Integer;
    function  GetHeight: Integer;
    function  HitTest(P: TPoint): Boolean; virtual;
    procedure InitButtonBitmaps(W, H: Integer); virtual;
    procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
    procedure PaintState(DC, MDC: HDC; Offset: Integer; bmButton: HBitmap); virtual;
    procedure BeginCapture(P: TPoint);
    procedure ContinueCapture(P: TPoint);
    function  EndCapture(SendTo: HWnd; P: TPoint): Boolean;
    procedure PressIn;
    procedure PressOut;
  end;


  PToolbar = ^TToolbar;
  TToolbar = object(TWindow)
    ResName: PChar;
    Tools: TCollection;
    Capture: PToolButton;
    constructor Init(AParent: PWindowsObject; AName: PChar);
    destructor Done; virtual;
    function  CreateTool(Num: Integer; Origin: TPoint; Command: Word; BitmapName: PChar): PToolButton; virtual;
    procedure EnableTool(Command: Word; NewState: Boolean); virtual;
    procedure FreeResName;
    function  GetClassName: PChar; virtual;
    procedure GetWindowClass(var WC: TWndClass); virtual;
    procedure SetResName(NewName: PChar);
    procedure NextToolOrigin(Num: Integer; var Origin: TPoint; P: PToolButton); virtual;
    procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
    procedure ReadResource; virtual;
    procedure SwitchTo(NewName: PChar);
    procedure amSetParentClientRect(var Msg: TMessage); virtual wm_First + am_SetParentClientRect;
    procedure wmLButtonDown(var Msg: TMessage); virtual wm_First + wm_LButtonDown;
    procedure wmMouseMove(var Msg: TMessage); virtual wm_First + wm_MouseMove;
    procedure wmLButtonUp(var Msg: TMessage); virtual wm_First + wm_LButtonUp;
  end;


implementation


function Max(A,B: Integer): Integer;
begin
  if A > B then
    Max := A
  else
    Max := B;
end;

{------------ TToolbar ----------------------}

constructor TToolbar.Init(AParent: PWindowsObject; AName: PChar);
begin
  TWindow.Init(AParent, nil);
  Attr.Style := ws_Child or ws_Visible or ws_Border;
  SetFlags(wb_MDIChild, False);
  DefaultProc := @DefWindowProc;
  Attr.X := -1;
  Attr.Y := -1;
  Attr.W := 100;
  Attr.H := 1;
  Capture := nil;
  ResName := nil;
  SetResName(AName);
  Tools.Init(8, 8);
  ReadResource;
end;


destructor TToolbar.Done;
begin
  TWindow.Done;
  Tools.Done;
  FreeResName;
end;


procedure TToolbar.ReadResource;

type
  ResRec = record
    Num,
    Bitmap,
    Command: Word;
  end;

  PResArray = ^TResArray;
  TResArray = array [0..$FFF0 div sizeof(ResRec)] of ResRec;

var
  ResIdHandle: THandle;
  ResDataHandle: THandle;
  ResDataPtr: PResArray;
  x: word;
  Origin: TPoint;
  BitInfo: TBitmap;
  P: PToolButton;

begin
  ResIDHandle := FindResource(HInstance, ResName, 'ToolBarData');
  ResDataHandle := LoadResource(HInstance, ResIDHandle);
  ResDataPtr := LockResource(ResDataHandle);
  if (ResIDHandle = 0) or (ResDataHandle = 0) or (ResDataPtr = nil) then
  begin
    Status := em_InvalidChild;
    Exit;
  end;

  x:= 0;
  Origin.X := 0;
  Origin.Y := 0;
  while (ResDataPtr^[x].Num = x) do
    with ResDataPtr^[x] do
    begin
      P := CreateTool(X, Origin, Command, PChar(Bitmap));
      if P <> nil then
      begin
        NextToolOrigin(X, Origin, P);
        Tools.Insert(P);
      end;
      Inc(X);
    end;

  if (ResDataPtr^[X].Num <> 0) and (ResDataPtr^[X].Num <> X) then
    Status := em_InvalidChild;

  UnlockResource(ResDataHandle);
  FreeResource(ResDataHandle);
end;


{ Override CreateTool to make Toolbar use a different kind of ToolButton object }

function TToolbar.CreateTool(Num: Integer; Origin: TPoint; Command: Word; BitmapName: PChar): PToolButton;
begin
  CreateTool := new(PToolButton, Init(@Self, Origin.X, Origin.Y, Command, BitmapName));
end;

procedure TToolbar.EnableTool(Command: Word; NewState: Boolean);

  function FoundIt(P: PToolbutton): Boolean; far;
  begin
    FoundIt := P^.Command = Command;
  end;

var
  P: PToolbutton;

begin
  P := Tools.FirstThat(@FoundIt);
  if P <> nil then
    P^.Enable(NewState);
end;


function TToolbar.GetClassName: PChar;
begin
  GetClassName := 'OWLToolbar';
end;

procedure TToolbar.GetWindowClass(var WC: TWndClass);
begin
  TWindow.GetWindowClass(WC);
  WC.hbrBackground := GetStockObject(LtGray_Brush);
end;


{ NextToolOrigin sets the origin for the next tool button based upon the current tool's
  size and the toolbar's primary orientation or layout system (horizontal, vertical,
  palette.  This method is called in the Toolbar's constructor after each tool that is
  added to the toolbar. }

procedure TToolbar.NextToolOrigin(Num: Integer; var Origin: TPoint; P: PToolButton);
begin
  Inc(Origin.X, P^.GetWidth);
  Attr.H := Max(Attr.H, P^.GetHeight);
end;


procedure TToolbar.Paint(DC: HDC; var PS: TPaintStruct);

  procedure PaintIt(Item: PToolButton); far;
  begin
    Item^.Paint(DC, PS);
  end;

begin
  Tools.ForEach(@PaintIt);
end;


{ FreeResName handles releasing memory, if necessary, occupied by a
  PChar / integer resource identifier }

procedure TToolbar.FreeResName;
begin
  if HiWord(Longint(ResName)) <> 0 then
    StrDispose(ResName);
end;

{ SetResName handles allocating memory, if necessary, to hold a PChar or
  integer resource identifier. }

procedure TToolbar.SetResName(NewName: PChar);
begin
  FreeResName;
  if HiWord(Longint(NewName)) <> 0 then
    ResName := StrNew(NewName)
  else
    ResName := NewName;
end;


{ Switch the Toolbar object to use a different toolbar resource. }

procedure TToolbar.SwitchTo(NewName: PChar);
begin
  Tools.Done;
  Tools.Init(8,8);
  SetResName(NewName);
  ReadResource;
end;

{ AMSetParentClientRect is a message sent to us from the main window.  LParam points to
  a TRect, which the main window will use to resize the MDI Client window.  You can
  modify this rect to move the client window down (horizontal toolbar) or left or right
  (vertical toolbar).  Note that other 'special' windows, such as a status line, may also
  modify the rect before or after the toolbar is given its chance.  Do not assume
  the rect always starts out as the main window's full client area.}

procedure TToolbar.AMSetParentClientRect( var Msg: TMessage);
var R,S : TRect;
begin
  if (Msg.wParam =  SizeNormal) or (Msg.wParam = SizeFullScreen) then
  begin
    GetClientRect(HWindow, R);
    GetClientRect(Parent^.HWindow, S);
    if R.Right <> S.Right then
      SetWindowPos(HWindow, 0, -1, -1, S.Right + 2, R.Bottom + 2, swp_NoZOrder or swp_NoRedraw);
    if R.Right < S.Right then
    begin
      S.Left := R.Right;
      S.Top := R.Top;
      S.Bottom := R.Bottom+1;
      InvalidateRect(HWindow, @S, True);
    end;
    if PRect(Msg.LParam)^.Top < R.Bottom then
      PRect(Msg.LParam)^.Top := R.Bottom+1;
  end;
end;


procedure TToolbar.WMLButtonDown(var Msg: TMessage);

  function IsHit(Item: PToolButton): Boolean; far;
  begin
    IsHit := Item^.HitTest(TPoint(Msg.LParam));
  end;

begin
  Capture := Tools.FirstThat(@IsHit);
  if Capture <> nil then
    Capture^.BeginCapture(TPoint(Msg.LParam));
end;

procedure TToolbar.wmMouseMove(var Msg: TMessage);
begin
  if (Capture <> nil) then
    Capture^.ContinueCapture(TPoint(Msg.LParam));
end;

procedure TToolbar.wmLButtonUp(var Msg: TMessage);
begin
  if (Capture <> nil) then
  begin
    if Capture^.EndCapture(Parent^.HWindow, TPoint(Msg.LParam)) then
      Capture := nil;  { DON'T dispose of the captured tool!! }
  end;
end;


{------------ TToolButton --------------------------}

constructor TToolButton.Init(AParent: PWindowsObject;
                             X, Y: Integer;
                             ACommand: Word;
                             BitmapName: PChar);
var
  BI: TBitmap;
  GrayBM, OldBM: HBitmap;
  OldPen: HPen;
begin
  TObject.Init;
  Parent := AParent;
  CapDC := 0;
  MemDC := 0;
  bmNormal := 0;
  bmPressed := 0;
  brGraying := 0;
  IsPressed := False;
  Capturing := False;
  IsEnabled := True;
  Command := ACommand;
  bmGlyph := LoadBitmap(HInstance, BitmapName);
  GetObject(bmGlyph, SizeOf(BI), @BI);
  GlyphSize.X := BI.bmWidth;
  GlyphSize.Y := BI.bmHeight;
  InitButtonBitmaps(GlyphSize.X, GlyphSize.Y);
  GetObject(bmNormal, SizeOf(BI), @BI);
  SetRect(R, X, Y, X + BI.bmWidth, Y + BI.bmHeight);
end;


destructor TToolButton.Done;
begin
  if Capturing then
  begin
    DeleteDC(MemDC);
    ReleaseDC(Parent^.HWindow, CapDC);
    ReleaseCapture;
  end;
  if bmGlyph <> 0 then DeleteObject(bmGlyph);
  if bmNormal <> 0 then DeleteObject(bmNormal);
  if bmPressed <> 0 then DeleteObject(bmPressed);
  if brGraying <> 0 then DeleteObject(brGraying);
  TObject.Done;
end;

procedure TToolButton.Enable(NewState: Boolean);
begin
  if (IsEnabled <> NewState) and (Parent^.HWindow <> 0) then
    InvalidateRect(Parent^.HWindow, @R, False);
  IsEnabled := NewState;
end;

function TToolButton.GetWidth: Integer;
begin
  GetWidth := R.Right - R.Left;
end;

function TToolButton.GetHeight: Integer;
begin
  GetHeight := R.Bottom - R.Top;
end;

function TToolButton.HitTest(P: TPoint): Boolean;
begin
  HitTest := Boolean(PtInRect(R,P));
end;

{ InitButtonBitmaps loads the button images that the tool button glyphs
  will be copied onto.  TToolButton assumes all the tool buttons on the toolbar
  will be the same size.  If you want variable sized (width or height or both)
  tool buttons, create a descendent of TToolButton and override this
  method to create or stretch the button image to suite each tool's
  glyph size.  Creating bitmaps for each toolbutton uses more memory
  than several toolbuttons referencing the same bitmap resource.
  String names are used to identify the bitmaps to avoid integer id
  collisions with other bitmaps in the application.
}

procedure TToolButton.InitButtonBitmaps(W, H: Integer);
var
  LBrush: TLogBrush;
  DC,SourceDC,DestDC: HDC;
  bmOld1, bmOld2: HBitmap;
begin
  bmNormal := LoadBitmap(HInstance, 'NormalToolButton');
  bmPressed := LoadBitmap(HInstance, 'PressedToolButton');

  LBrush.lbStyle := bs_Pattern;
  Word(LBrush.lbHatch) := LoadBitmap(HInstance, 'GrayingBitmap');
  brGraying := CreateBrushIndirect(LBrush);
  DeleteObject(Word(LBrush.lbHatch));
end;


procedure TToolButton.Paint(DC: HDC; var PS: TPaintStruct);
var
  M: HDC;
begin
  M := CreateCompatibleDC(DC);
  PaintState(DC, M, 0, bmNormal);
  DeleteDC(M);
end;

procedure TToolButton.PaintState(DC, MDC: HDC; Offset: Integer; bmButton: HBitmap);
var
  bmOld: HBitmap;
  OldBrush: HBrush;
  OldOrg: Longint;
begin
  bmOld := SelectObject(MDC, bmButton);
  BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
         MDC, 0, 0, SrcCopy);
  SelectObject(MDC, bmGlyph);
  if IsEnabled then
    BitBlt(DC, R.Left+Offset+1, R.Top+1+Offset, GlyphSize.X, GlyphSize.Y,
           MDC, 0, 0, SrcCopy)
  else
  begin
    UnRealizeObject(brGraying);
    OldBrush := SelectObject(DC, brGraying);
    BitBlt(DC, R.Left+Offset+1, R.Top+Offset+1, GlyphSize.X, GlyphSize.Y,
           MDC, 0, 0, $00A803A9 {DPSoa});
    SelectObject(DC, OldBrush);
  end;
  SelectObject(MDC, bmOld);
end;

procedure TToolButton.PressIn;
begin
  if (not IsPressed) and IsEnabled then
  begin
    IsPressed := True;
    PaintState(CapDC, MemDC, 1, bmPressed);
  end;
end;

procedure TToolButton.PressOut;
begin
  if IsPressed then
  begin
    IsPressed := False;
    PaintState(CapDC, MemDC, 0, bmNormal);
  end;
end;

procedure TToolButton.BeginCapture(P: TPoint);
begin
  CapDC := GetDC(Parent^.HWindow);
  MemDC := CreateCompatibleDC(CapDC);
  IsPressed := False;
  Capturing := True;
  SetCapture(Parent^.HWindow);
  if HitTest(P) then
    PressIn;
end;

procedure TToolButton.ContinueCapture(P: TPoint);
begin
  if HitTest(P) then
    PressIn
  else
    PressOut;
end;


{ The boolean function result of EndCapture indicates whether the tool button
  has released the mouse capture or not.  The Toolbar should not clear its
  capture field/state until the toolbutton says to.

  The SendTo parameter is the HWindow to notify that the tool button was clicked
  upon, if such is the case.  This code emulates a menu command message, but
  any message type could be used. }

function TToolButton.EndCapture(SendTo: HWnd; P: TPoint): Boolean;
begin
  if HitTest(P) then
  begin
    PressOut;
    PostMessage(SendTo, wm_Command, Command, 0);
  end;
  EndCapture := True;
  ReleaseCapture;
  Capturing := False;
  DeleteDC(MemDC);
  ReleaseDC(Parent^.HWindow, CapDC);
  MemDC := 0;
  CapDC := 0;
end;


end.