explbtn.pas

地址档案管理系统

(*
 *  TExplorerButton version 3.0
 *  TExplorerPopup version 1.0
 *  (c)1996-1997 Fabrice Deville
 *  [e-mail]
 *  http://www.tornado.be/~fdev/
 *
 *  Shareware source - compiles under Delphi 1.0 & 2.0
 *
 *  The source code can not be redistributed
 *
 *)

{$IFDEF WIN32}
{$ObjExportAll On} {export all objects (for C++Builder 3.0)}
{$ENDIF}

unit ExplBtn;

interface

uses
  WinTypes, WinProcs, Messages,
  ImgList,
  SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, DesignIntf, ExtCtrls;

const
  WM_EXPLORERPOPUPOPEN=WM_USER+100;

type
  { TExplorerPopup declaration }

  TExplorerPopup = class(TCustomPanel)
  private
    FUndockable: Boolean;
    FOnClose: TNotifyEvent;
    FOnOpen: TNotifyEvent;
    FOnUndock: TNotifyEvent;
    FUndockThreshold: Integer;
    FHideInactive: Boolean;
    FRedockable: Boolean;
    clicked, FUndocked, titleFocused, terminated: Boolean;
    mousex, mousey: Integer;
    oldParent: TWinControl;
  protected
    procedure SetUndockable(value: Boolean);
    procedure Paint; override;
    procedure WMLButtonDown(var msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var msg: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMMouseMove(var msg: TWMMouseMove); message WM_MOUSEMOVE;
    procedure Loaded; override;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure DockedFormClose(Sender: TObject; var Action: TCloseAction);
    procedure ShiftControlsUpDown(offset: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Open(btn: TControl);
    procedure Close;
    procedure CloseIfDocked;
  published
    property Undockable: Boolean read FUndockable write SetUndockable stored True default True;
    property UndockThreshold: Integer read FUndockThreshold write FUndockThreshold stored True default 10;
    property Undocked: Boolean read FUndocked;
    property HideInactive: Boolean read FHideInactive write FHideInactive stored True default True;
    property Redockable: Boolean read FRedockable write FRedockable stored True default True;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnUndock: TNotifyEvent read FOnUndock write FOnUndock;
    property Caption;
  end;

  { TExplorerButton declaration }

  TExplorerButtonLayout = (blBitmapTop, blBitmapBottom, blBitmapLeft, blBitmapRight);
  TExplorerButtonOption = (boMonoDisplay, boIconOnly, boPopupMark, boShowBevel,
                          boShowDownPattern, boTransparent, boWordWrap, boNoDepress);
  TExplorerButtonOptions = set of TExplorerButtonOption;
  TExplorerButtonShadingType = (stLight, stMedium, stDark);
  TExplorerButtonDropDownStyle = (ddsIExplorer, ddsOffice);
  TExplorerButtonButtonSize = (bsCustom, bsSmall, bsLarge);

  TExplorerButton = class(TCustomControl)
  private
    FDefault: Boolean;
    FCancel: Boolean;
    FActive: Boolean;
    FAlignment: TAlignment;
    FAllowAllUp: Boolean;
    FBevelStyle: TBevelStyle;
    FBitmap, FNoFocusBitmap, FDisabledBitmap, IBitmap: TBitmap;
    FCaption: TCaption;
    FDown: Boolean;
    FDropDown: TPopupMenu;
    FDropDownStyle: TExplorerButtonDropDownStyle;
    FEnabled: Boolean;
    FExplorerPopup: TExplorerPopup;
    FGroupIndex: Integer;
    FLayout: TExplorerButtonLayout;
    FOnDropDownClick: TNotifyEvent;
    FOptions: TExplorerButtonOptions;
    FShadingType: TExplorerButtonShadingType;
    FUnselectedFontColor: TColor;
    FOnEnter, FOnExit: TNotifyEvent;
    (* state flags *)
    popupPushed, Pushed, MouseIn, popupOpened: Boolean;
    painted, backBitmapCreated, initialized, wasObscured, regenerating: Boolean;
    backBitmap: TBitmap;

    FSmallWidth, FSmallHeight, FLargeWidth, FLargeHeight, FCustomWidth, FCustomHeight: Integer;
    FButtonSize: TExplorerButtonButtonSize;
    updatingSize, fakeResize: Boolean;
  protected
    procedure SetButtonStyle(ADefault: Boolean); virtual;
    procedure SetDefault(Value: Boolean);
    procedure CreateWnd; override;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure ComputeExtent(TempCaption: PChar; var TempRect: TRect; theCanvas: TCanvas);
    procedure CreateGrayscaleBitmap(outputbmp, bmp: TBitmap);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadIBitmap(Stream: TStream);
    procedure WriteIBitmap(Stream: TStream);
    procedure DrawTheText(theCanvas: TCanvas; TempRect: TRect; TempCaption: PChar);
    procedure DrawDisabledText(theCanvas: TCanvas; TempRect: TRect; TempCaption: PChar);
    procedure DrawPopupMark(theCanvas: TCanvas; x, y: Integer);
    procedure DrawOutline(theCanvas: TCanvas; pushed: Boolean);
    procedure GetLost;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override ;
    function  Obscured: boolean;
    procedure BitmapChange(Sender: TObject);
    procedure NoFocusBitmapChange(Sender: TObject);
    procedure DisabledBitmapChange(Sender: TObject);
    procedure Paint; override;
    procedure SetAlignment(value: TAlignment);
    procedure SetAllowAllUp(value: Boolean);
    procedure SetBevelStyle(value: TBevelStyle);
    procedure SetBitmap(value: TBitmap);
    procedure SetCaption(value: TCaption);
    procedure SetDisabledBitmap(value: TBitmap);
    procedure SetDown(value: Boolean);
    procedure SetDropDown(value: TPopupMenu);
    procedure SetDropDownStyle(value: TExplorerButtonDropDownStyle);
    procedure SetEnabled(value: Boolean); {$IFDEF VER120} override; {$ENDIF}
    procedure SetExplorerPopup(value: TExplorerPopup);
    procedure SetGroupIndex(value: Integer);
    procedure SetLayout(value: TExplorerButtonLayout);
    procedure SetNoFocusBitmap(value: TBitmap);
    procedure SetOptions(value: TExplorerButtonOptions);
    procedure SetShadingType(value: TExplorerButtonShadingType);
    procedure SetUnselectedFontColor(value: TColor);
    procedure WMRButtonUp(var msg: TWMRButtonUp); message WM_RBUTTONUP;
    procedure WMLButtonDblClk(var msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMLButtonDown(var msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var msg: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMSize(var msg: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMMove(var msg: TWMMove); message WM_MOVE;
    procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
    procedure CMSysColorChange(var msg: TMessage); message CM_SYSCOLORCHANGE;

    procedure SetSmallWidth(value: Integer);
    procedure SetSmallHeight(value: Integer);
    procedure SetLargeWidth(value: Integer);
    procedure SetLargeHeight(value: Integer);
    procedure SetCustomWidth(value: Integer);
    procedure SetCustomHeight(value: Integer);
    procedure SetButtonSize(value: TExplorerButtonButtonSize);
    procedure DrawTransparentBitmap(theCanvas: TCanvas; bmp: TBitmap; xStart, yStart: Integer);
    procedure DrawDisabledBitmap(Canvas: TCanvas; x, y: Integer; bmp: TBitmap);

  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure Regenerate;
    procedure WMExplorerPopupOpen(var msg: TMessage); message WM_EXPLORERPOPUPOPEN;
  published
    (* new properties *)
    property Cancel: Boolean read FCancel write FCancel default False;
    property Default: Boolean read FDefault write SetDefault default False;
    property Alignment: TAlignment read FAlignment write SetAlignment stored True default taCenter;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp stored True default False;
    property BevelStyle: TBevelStyle read FBevelStyle write SetBevelStyle stored True default bsRaised;
    property NoFocusBitmap: TBitmap read FNoFocusBitmap write SetNoFocusBitmap stored True;
    property Bitmap: TBitmap read FBitmap write SetBitmap stored True;
    property Caption: TCaption read FCaption write SetCaption stored True;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex stored True default 0;
    property DisabledBitmap: TBitmap read FDisabledBitmap write SetDisabledBitmap stored True;
    property Down: Boolean read FDown write SetDown stored True default False;
    property DropDownMenu: TPopupMenu read FDropDown write SetDropDown stored True;
    property DropDownStyle: TExplorerButtonDropDownStyle read FDropDownStyle write SetDropDownStyle stored True;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property ExplorerPopup: TExplorerPopup read FExplorerPopup write SetExplorerPopup stored True;
    property Layout: TExplorerButtonLayout read FLayout write SetLayout stored True default blBitmapTop;
    property Options: TExplorerButtonOptions read FOptions write SetOptions stored True;
    property ShadingType: TExplorerButtonShadingType read FShadingType write SetShadingType stored True default stMedium;
    property UnselectedFontColor: TColor read FUnselectedFontColor write SetUnselectedFontColor stored True
             default clWindowText;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property OnDropDownClick: TNotifyEvent read FOnDropDownClick write FOnDropDownClick;

    property SmallWidth: Integer read FSmallWidth write SetSmallWidth stored True default 23;
    property SmallHeight: Integer read FSmallHeight write SetSmallHeight stored True default 22;
    property LargeWidth: Integer read FLargeWidth write SetLargeWidth stored True default 39;
    property LargeHeight: Integer read FLargeHeight write SetLargeHeight stored True default 38;
    property CustomWidth: Integer read FCustomWidth write SetCustomWidth stored True;
    property CustomHeight: Integer read FCustomHeight write SetCustomHeight stored True;
    property ButtonSize: TExplorerButtonButtonSize read FButtonSize write SetButtonSize stored True default bsCustom;

    (* republished properties *)
    property Font;
    property OnClick;
    property OnDblClick;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnDragDrop;
    property OnDragOver;
    property PopupMenu;
    property HelpContext;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property TabStop;
    property TabOrder;
 end;

procedure Register;

var
   bool_Version95 : Boolean;
   pattern: TBitmap;

implementation

const SMALLBITMAPWIDTH=16;
     SMALLBITMAPHEIGHT=16;
      LARGEBITMAPWIDTH=32;
      LARGEBITMAPHEIGHT=32;

var
  activeExplorerPopup: TExplorerPopup;
  activeExplorerButton: TExplorerButton;

{
  *********************************************************
  *
  *  TExplorerPopup implementation
  *
  *********************************************************
}

{$IFNDEF WIN32}
{
  16 bit: no small caption style, so this is my own implementation of the form.
  Tries to respect the style of Windows 3.1/NT 3.51 or Windows 95/NT4.
  No depress effect is implemented.
}
type
    TExplorerPopupForm = class(TForm)
    protected
        topDock, leftDock: integer;
        leftHome, redocked, checkRedock, hideInactive: Boolean;
        procedure WMNCHitTest(var msg: TMessage); message WM_NCHITTEST;
        procedure WMNCLButtonDown(var msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
       procedure WMActivateApp(var msg: TWMActivateApp); message WM_ACTIVATEAPP;
        procedure Paint; override;
    published
        property Caption;
    end;

procedure TExplorerPopupForm.WMNCHitTest(var msg: TMessage);
begin
     msg.Result := HTCAPTION;
end;

procedure TExplorerPopupForm.Paint;
begin
     with Canvas do
     begin
          Brush.Style := bsSolid;
          Brush.Color := clBtnFace;
          Pen.Style := psClear;
          Rectangle(0, 0, Width, Height);
          Pen.Color := clBtnHighlight;
          Pen.Style := psSolid;
          MoveTo(1, Height - 2);
          LineTo(1, 1);
          LineTo(Width - 2, 1);
          Pen.Color := clBtnShadow;
          LineTo(Width - 2, Height - 2);
          LineTo(1, Height - 2);
          Pen.Color := clBlack;
          MoveTo(0, Height - 1);
          LineTo(Width - 1, Height - 1);
          LineTo(Width - 1, 0);

          Font.Name := 'MS Sans Serif';
          Font.Size := 6;
          Font.Color := clCaptionText;
          Brush.Color := clActiveCaption;
          Brush.Style := bsSolid;
          Pen.Style := psClear;
          Rectangle(3, 3, Width - 2, 19);

          if not bool_Version95 then
          begin
              (* Win 31 style close button *)
              Brush.Color := clBtnFace;
              Pen.Style := psSolid;
              Pen.Color := clBtnHighLight;
              Rectangle(5, 5, 17, 17);
              Pen.Color := clBtnShadow;
              MoveTo(5, 16);
              LineTo(16, 16);
              LineTo(16,5);
              Pen.Style := psClear;
              Brush.Color := clBtnShadow;
              Rectangle(8, 10, 16, 14);
              Brush.Color := clBlack;
              Rectangle(7, 9, 15, 13);
              Pen.Style := psSolid;
              Pen.Color := clWhite;
              MoveTo(8,10);
              LineTo(13,10);
          end
          else
          begin
              (* Win 95 style close button *)
              Brush.Color := clBtnFace;
              Rectangle(Width - 17, 6, Width - 6, 15);
              Pen.Style := psSolid;
              Pen.Color := clBlack;
              MoveTo(Width - 18, 15);
              LineTo(Width - 6, 15);
              LineTo(Width - 6, 4);
              Pen.Color := clBtnShadow;
              MoveTo(Width - 17, 14);
              LineTo(Width - 7, 14);
              LineTo(Width - 7, 5);
              Pen.Color := clBtnHighlight;
              MoveTo(Width - 18, 14);
              Lineto(Width - 18, 5);
              LineTo(Width - 6, 5);
              Pen.Color := clBlack;
              MoveTo(Width - 15, 8);
              LineTo(Width - 10, 13);
              MoveTo(Width - 14, 8);
              LineTo(Width - 9, 13);
              MoveTo(Width - 15, 12);
              LineTo(Width - 10, 7);
              MoveTo(Width - 14, 12);
              LineTo(Width - 9, 7);
          end;

          Pen.Style := psSolid;
          Brush.Style := bsClear;
          if bool_Version95 then
              TextRect(Rect(6, 3, Width - 19, 18), 6, 4, Caption)
          else
              TextRect(Rect(20, 3, Width - 4, 18), 20, 4, Caption)
     end;
end;

procedure TExplorerPopupForm.WMNCLButtonDown(var msg: TWMNCLButtonDown);
var
  p: TPoint;
begin
  p := ScreenToClient(Point(msg.XCursor, msg.YCursor));
  if not bool_Version95 then
  begin
    if (p.x > 5) and (p.y > 4) and (p.y < 15) and (p.x < 15) then
      Close
     else
       inherited;
  end
  else
  begin
    if (p.x > Width - 19) and (p.y > 4) and (p.y < 18) and (p.x < Width - 4) then
      Close
     else
       inherited
  end;
end;

{$ELSE}
  type
    TExplorerPopupForm = class(TForm)
    protected
     topDock, leftDock: integer;
     leftHome, redocked, checkRedock, hideInactive: Boolean;
      procedure WMMoving(var msg: TMessage); message WM_MOVING;
     procedure WMActivateApp(var msg: TWMActivateApp); message WM_ACTIVATEAPP;
    end;

procedure TExplorerPopupForm.WMMoving(var msg: TMessage);
var
  rect: TRect;
begin
  if checkRedock then
  begin
    rect := PRECT(msg.lParam)^;
    if (not leftHome) and ((Abs(rect.Top - topDock) > 40) or (Abs(rect.Left - leftDock) > 40)) then
      leftHome := True;
    if leftHome and (Abs(rect.Top - topDock) < 10) and (Abs(rect.Left - leftDock) < 50) then
    begin
      redocked := True;
      SendMessage(Handle, WM_CANCELMODE, 0, 0);
    end
  end
end;
{$ENDIF}

procedure TExplorerPopupForm.WMActivateApp(var msg: TWMActivateApp);
begin
  if hideInactive then
  begin
    if msg.Active then
      Show
    else
      Hide
  end
end;

{ TExplorerPopup implementation }
constructor TExplorerPopup.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);
     BevelOuter := bvRaised;
     clicked := False;