cmpdialogbox.pas

學習資料網上下載

(*======================================================================*
 | DialogBox                                                            |
 |                                                                      |
 | Display a dialog box from a dialog resource template                 |
 |                                                                      |
 | Version  Date        By    Description                               |
 | -------  ----------  ----  ------------------------------------------|
 | 1.0      30/05/2001  CPWW  Original                                  |
 *======================================================================*)

unit cmpDialogBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, commctrl, richedit, DialogConsts, Menus;

type
  TOnDlgMessage = procedure (sender : TObject; var msg : TMessage; bcontinue : boolean) of object;
  TOnGetControlImage = procedure (Sender: TObject; tp : Integer; const id : string; var Handle: HGDIOBJ) of object;

//-----------------------------------------------------------------------
// The DialogBox class

  TDialogBox = class(TWinControl)
  private
    fResourceTemplate: pointer;
    fExtendedTemplate : Boolean;

    fHwndDlg : HWND;
    fHFontDlg : HFONT;
    fOnDlgMessage: TOnDlgMessage;

    fBaseUnitX, fBaseUnitY : Double;
    fMargin: Integer;
    fWidthAdjust: Integer;
    fHeightAdjust: Integer;
    fOnShow: TNotifyEvent;
    fOnGetControlImage: TOnGetControlImage;

    fOrigStyle : DWORD;
    fMenu : TMenuItem;

    procedure SetResourceTemplate(const Value: pointer);
    procedure WmDestroy (var msg : TwmDestroy); message WM_DESTROY;
    procedure InitDialogControls;

  protected
    fOrigX, fOrigY : Integer;
    fInitializing : boolean;
    procedure HandleDlgMessage (var Msg : TMessage); virtual;
    procedure PaintWindow (DC : HDC); override;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    property WidthAdjust : Integer read fWidthAdjust write fWidthAdjust;
    property HeightAdjust : Integer read fHeightAdjust write fHeightAdjust;
    procedure InitDlg (template : Pointer; const fontName : string; fontPoints, fontWeight, fontCharset : Integer; fontItalic : Boolean; const menu, cls : TSzOrID); virtual;
    procedure InitCtrl (n : Integer; template : Pointer; extraCount : Integer; extraData : PChar; titleSzOrID : TSzOrID); virtual;

    property ExtendedTemplate : Boolean read fExtendedTemplate;

    property OrigStyle : DWORD read fOrigStyle write fOrigStyle;
    property OrigX : Integer read fOrigX write fOrigX;
    property OrigY : Integer read fOrigY write fOrigY;

    function PointToDialogPoint (pt : TPoint) : TPoint;
    function DialogPointtoPoint (pt : TPoint) : TPoint;
    function RectToDialogRect (r : TRect) : TRect;
    function DialogRectToRect (r : TRect) : TRect;

    property FontHandle : HFONT read fHFontDlg; // Must be read only!  Don't even think about it!
    { Protected declarations }
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;

    property Margin : Integer read fMargin write fMargin;
    property ResourceTemplate : pointer read fResourceTemplate write SetResourceTemplate;

    property DialogHandle : HWND read fHwndDlg;
    procedure SetCtrlImage (hwndCtrl : HWND; isBtn : Boolean; tp : Integer; Handle : HGDIOBJ);
    procedure GetImageType (const ctrlClass : TSZOrID; Style : DWORD; var isBtn : Boolean; var tp : Integer);
    procedure SetCtrlImage1 (hwndCtrl : HWND; isBtn : Boolean; tp : Integer; id : TszOrID);

  published
    property OnDlgMessage : TOnDlgMessage read fOnDlgMessage write fOnDlgmessage;
    property AutoSize default True;
    property Color default clBtnFace;
    property OnKeyDown;
    property ParentColor;
    property OnResize;
    property OnShow : TNotifyEvent read fOnShow write fOnShow;
    property OnGetControlImage : TOnGetControlImage read fOnGetControlImage write fOnGetControlImage;
    { Published declarations }
  end;

var
  gWndAtom : TAtom;

procedure WriteSzOrId (stream : TStream; const id : TSzOrId);
procedure Pad (stream : TStream);
procedure GetSzOrID (var p : PChar; var szOrID : TSzOrID);
function StringToSzOrID (const st : string) : TszOrID;

implementation

var
  gTmpFont : HFONT = 0;
  FRichEditModule: THandle;

(*----------------------------------------------------------------------*
 | DialogProc                                                           |
 |                                                                      |
 | Handle dialog messages.                                              |
 |                                                                      |
 | When we receive WM_INITDIALOG, set up the thunk to the TDialogBox    |
 | instance using SetProp.  Once we've got the TDialogBox thunk, we can |
 | call TDialogBox.HandleDlgMessage to do the work.                     |
 |                                                                      |
 | The only snag is that dialogs can get sent a WM_SETFONT message,     |
 | even before the WM_INITDIALOG.  So we save the font handle in        |
 | gTmpFont, then send on the WM_SETFONT after we've received           |
 | WM_INITDIALOG.  Sorry about the global, but heaven help you if       |
 | try to simultaneously create two dialogs from diffent threads!       |
 *----------------------------------------------------------------------*)
function DialogProc (hwndDlg : HWND; uMsg : UINT; wParam : WPARAM; lParam : LPARAM) : BOOL; stdcall;
var
  dlgInstance : TDialogBox;
  msg : TMessage;

begin
  result := False;
  if uMsg = WM_INITDIALOG then
  begin
    dlgInstance := TDialogBox (lParam);                 // Get the TDialogBox instance from lparam
    SetProp (hwndDlg, PChar (gWndAtom), lParam);        // ... and save it in the gWndAtom property
    dlgInstance.fhwndDlg := hwndDlg;

    if gTmpFont <> 0 then                               // Now do delayed WM_SETFONT.
    begin
      SendMessage (hwndDlg, WM_SETFONT, gTmpFont, 0);
      gTmpFont := 0
    end
  end
  else                                                  // Look up TDialogBox in prop.

    dlgInstance := TDialogBox (GetProp (hwndDlg, PChar (gWndAtom)));

  if Assigned (dlgInstance) then
  begin
    msg.Msg := uMsg;
    msg.WParam := wParam;
    msg.LParam := lParam;
    msg.Result := 0;

    dlgInstance.HandleDlgMessage (msg);
    result := Bool (msg.Result);

    if uMsg = WM_DESTROY then                           // WM_DESTROY - remove the prop, otherwise
    begin                                               // the window won't be destroyed!
      SetParent (dlgInstance.fhwndDlg, 0);
      dlgInstance.fhwndDlg := 0;
      RemoveProp (hwndDlg, PChar (gWndAtom));
      result := True;
    end
  end
  else                       // No TDialogBox - implies we haven't yet received WM_INITDIALOG
                             // The only message we accept at this stage is WM_SETFONT...
    if uMsg = WM_SETFONT then
      gTmpFont := wParam
end;

(*----------------------------------------------------------------------*
 | GetSzOrID                                                            |
 |                                                                      |
 | Get a 'string or ID' from a class, menu, title dialog template value |
 | pointer.                                                             |
 *----------------------------------------------------------------------*)
procedure GetSzOrID (var p : PChar; var szOrID : TSzOrID);
begin
  if (PWord (p)^ = $ffff) then
  begin
    Inc (p, SizeOf (Word));
    szOrID.isID := True;
    szOrId.id := PWord (p)^;
    szOrId.sz := '';
    Inc (p, SizeOf (Word));
  end
  else
  begin
    szOrId.isID := False;
    szOrId.sz := PWideChar (p);
    szOrId.Id := 0;
    Inc (p, SizeOf (WideChar) * (Length (szOrId.sz) + 1))
  end
end;

procedure WriteSzOrId (stream : TStream; const id : TSzOrId);
var
  w : Word;
  ws : WideString;
begin
  if id.isID then
  begin
    w := $ffff;
    stream.Write (w, SizeOf (w));

    w := id.id;
    stream.Write (w, SizeOf (w))
  end
  else
  begin
    ws := id.sz;
    stream.Write (ws [1], (Length (ws) + 1) * SizeOf (WideChar))
  end
end;

procedure Pad;
var
  padding : Integer;
begin
  if stream.Position mod 4 <> 0 then
  begin
    padding := 0;
    stream.Write (padding, 4 - (stream.Position mod 4))
  end
end;

function StringToSzOrID (const st : string) : TszOrID;
var
  i : Integer;
begin
  result.isID := True;
  result.sz := st;

  for i := 1 to Length (st) do
    if not (st [i] in ['0'..'9']) then
    begin
      result.isID := False;
      break
    end;

  if result.isID then
  begin
    result.id := StrToInt (st);
    if result.id > $ffff then
      result.isID := False
  end;

  if result.isID then
    result.sz := ''
  else
    result.id := 0
end;

{ TDialogBox }

(*----------------------------------------------------------------------*
 | TDialogBox.CanAutoSize                                               |
 |                                                                      |
 | Override 'CanAutoSize' to allow size for the margin.  The margin is  |
 | important an TDialogEditor, as it holds the resizer control for the  |
 | dialog itself.                                                       |
 *----------------------------------------------------------------------*)
function TDialogBox.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
var
  r : TRect;
  w, h : Integer;
begin
  Result := True;
  if not (csDesigning in ComponentState) then
  begin
    if fHWndDlg <> 0 then
      GetWindowRect (fHWndDlg, r)
    else
      FillChar (r, SizeOf (r), 0);

    w := r.Right - r.Left + 1;
    h := r.Bottom - r.Top + 1;

    if Align in [alNone, alLeft, alRight] then
      NewWidth := w + 2 * Margin + WidthAdjust;

    if Align in [alNone, alTop, alBottom] then
      NewHeight := h + 2 * Margin + HeightAdjust;
  end
end;

(*----------------------------------------------------------------------*
 | TDialogBox.Create                                                    |
 |                                                                      |
 | Constructor.  Set property defaults.                                 |
 *----------------------------------------------------------------------*)
constructor TDialogBox.Create(AOwner: TComponent);
begin
  inherited;
  width := 180;
  height := 120;
  Color := clBtnFace;
  AutoSize := True;
end;

(*----------------------------------------------------------------------*
 | TDialogBox.DialogPointToPoint                                        |
 |                                                                      |
 | Convert a point from dialog units to pixels                          |
 *----------------------------------------------------------------------*)
destructor TDialogBox.Destroy;
begin
  fMenu.Free;

  inherited;
end;