tinyapp.pas

是和Delphi 编程精选集锦书本配套的源码

{*******************************************************}
{                                                       }
{          Tiny application frame                       }
{                                                       }
{          Copyright(c) 1999..2000,   Su Chengxiang     }
{                                                       }
{*******************************************************}

Unit TinyApp;

{$R-}

Interface

uses
  SysUtils, Windows, Messages, ShellAPI, SuObject;

function MainWndProc(AhWnd: HWND; AMessage: UINT; wParam: WPARAM;
                    lParam: LPARAM): LRESULT; StdCall; export;

const
  MaxIconNum = 10;
  IDI_MyFirst = 17;
  WM_MyMessage1 = WM_USER + 580;
  SuWndClassName: PChar = 'SucxWindow';
  AboutWndText: PChar = '  Logbook v1.0'#13#10#13#10'欢迎使用,版权保留' +
                '       '#13#10#13#10'2000, 苏成翔,王峰       ';
type
{ TWindowObject creation attributes }

  TWindowAttr = record
    Title: PChar;
    Style: LongWord;
    ExStyle: LongWord;
    X, Y, W, H: Integer;
    Param: Pointer;
    case Integer of
      0: (Menu: HMENU);         { Menu handle }
      1: (Id: Integer);         { Child identifier }
  end;

{ TWindowObject - Window object }

  PWindowObject = ^TWindowObject;
  TWindowObject = object(TSObject)
    FHWindow: HWND;
    FAttr: TWindowAttr;
    FWndClass: WNDCLASSEX;
    FParent,
    FChild: PWindowObject;
    FIsMain: Bool;
    FErrorCode: DWORD;
    constructor Create(HParent: PWindowObject);
    destructor Destroy; virtual;
    function GetClassName: PChar; virtual;
    function InitAttr: Bool; virtual;
    function InitClass: Bool; virtual;
    function InitWindow: Bool;
    procedure SetChild(Child: PWindowObject);
    procedure Show(ShowCmd: Integer);
    procedure Update;
   end;

{ TMWindow - Main Window }

  PMWindow = ^TMWindow;
  TMWindow = object(TWindowObject)
    FTitle: PChar;
    constructor Create(ATitle: PChar; HParent: PWindowObject);
    function InitAttr: Bool; virtual;
    function InitClass: Bool; virtual;
    function CanClose: Bool;  virtual;
   end;

{ TTrayIconObject - Tray icon object }

  IDRec = record
    ID: UINT;
    Used: Boolean;
   end;
  IDArray = array[1..MaxIconNum] of IDRec;

  PTrayIconObject = ^TTrayIconObject;
  TTrayIconObject = object(TSObject)
    FNotifyIconData: TNotifyIconData;
    FIconNum: Integer;
    FIconIDs: IDArray;
    FErrorCode: DWORD;
    constructor Create(AHWnd: HWND);
    destructor Destroy; virtual;
    function Add(AuID: UINT; AHIcon: HICON; TipStr: string): Bool;
    function Delete(AuID: UINT): Bool;
    function Modify(AuID: UINT; AHIcon: HICON; TipStr: string): Bool;
   end;

{ TTinyApp - tiny application frame }

  PTinyApp = ^TTinyApp;
  TTinyApp = object(TSObject)
    FAppName: PChar;
    FHInstance: HINST;
    FMainWindow: PWindowObject;
    FTrayIcon: PTrayIconObject;
    FTerminate: Bool;
    FReturnValue: Integer;
    FErrorCode: DWORD;
    constructor Create(Name: ShortString);
    destructor Destroy; virtual;
    function CreateMainWindow: PWindowObject;
    function CreateTrayIcon: PTrayIconObject;
    function DoOnStart: Bool; virtual;
    function DoOnExit: Bool; virtual;
    procedure HandleMessage;
    function NotFirst: Bool;
    procedure ProcessError;
    function ProcessMessage: Bool;
    procedure Run;
    function ShowMessage(Text, Caption: PChar; Flags: Longint): Integer;
  end;

Implementation

function MainWndProc(AhWnd: HWND; AMessage: UINT; wParam: WPARAM;
                    lParam: LPARAM): LRESULT; StdCall; export;
var  QUIT_POST: Bool;
begin
  Result:= 0;
  QUIT_POST:= False;
  case AMessage of
    WM_DESTROY,
    WM_QUERYENDSESSION,
    WM_ENDSESSION:
     if not QUIT_POST then
      begin                   // posts a WM_QUIT message to the app's message
       PostQuitMessage(0);    // queue and returns immediately
       QUIT_POST:= True;
       Result:= 1;
      end;
    WM_COMMAND:
      Result:= DefWindowProc(AhWnd, AMessage, wParam, lParam);
    WM_MyMessage1:
      case lParam of
        WM_LBUTTONDBLCLK:
         begin
          MessageBoxEx(AhWnd, AboutWndText, '□About Logbook',
            MB_OK or MB_ICONEXCLAMATION or MB_SETFOREGROUND, LANG_CHINESE);
         end;
      end;
   else
    Result:= DefWindowProc(AhWnd, AMessage, wParam, lParam);
  end;
end;

{ TWindowObject }

constructor TWindowObject.Create(HParent: PWindowObject);
begin
  inherited Create;
  FHWindow:= 0;
  FParent:= HParent;
  FChild:= nil;
  if (HParent = nil) then FIsMain:= True  else FIsMain:= False;
  InitAttr;
  if InitClass then
    InitWindow;
end;

destructor TWindowObject.Destroy;
begin
  if (FChild <> nil) then FChild^.Free;
  if (FHWindow <> null) then DestroyWindow(FHWindow);
  UnRegisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
  inherited destroy;
end;

function TWindowObject.GetClassName: PChar;
begin
  Result:= SuWndClassName;
end;

function TWindowObject.InitAttr: Bool;
begin
  with FAttr do
   begin
    Title:= '';
    Style:= WS_POPUPWINDOW or WS_CAPTION or WS_MINIMIZEBOX;
    ExStyle:= 0;   //no extended styles
    X:= 100;
    Y:= 100;
    W:= 100;
    H:= 60;
    Param:= nil;
    Menu:= 0;      //menu handle
   end;
  Result:= True;
end;

{ Registers the TWindowsObject's MS-Windows, if not already registered. }

function TWindowObject.InitClass: Bool;
begin
  with FWndClass do
   begin
    cbSize:=        sizeof(FWndClass);
    Style:=         cs_GlobalClass;
    lpfnWndProc:=   @DefWindowProc;
    cbClsExtra:=    0;           //no extra class memory
    cbWndExtra:=    0;           //no extra window memory
    hInstance:=     SysInit.HInstance;
    hIcon:=         LoadIcon(null, IDI_APPLICATION);
    hCursor:=       LoadCursor(null, IDC_ARROW);
    hbrBackGround:= GetStockObject(LTGray_Brush);
    lpszMenuName:=  nil;
    lpszClassName:= GetClassName;
    hIconSm:=       LoadIcon(null, IDI_APPLICATION);
   end;
  Result:= Bool(RegisterClassEX(FWndClass));
end;

function TWindowObject.InitWindow: Bool;
var  Parent: HWND;
begin
  Result:= False;
  if FParent <> nil then
    Parent:= FParent.FHWindow  else
    Parent:= 0;
  //If the function succeeds, the return value is the handle to the new window.
  //If fails, the return value is NULL.
   FHWindow:= CreateWindowEx(
      FAttr.ExStyle,      // extended window style
      GetClassName,       // pointer to registered class name
      FAttr.Title,        // pointer to window name
      FAttr.Style,        // window style
      FAttr.X, FAttr.Y, FAttr.W, FAttr.H,     // position
      Parent,             // handle to parent or owner window
      FAttr.Menu,         // handle to menu, or child-window identifier
      SysInit.HInstance,  // handle to application instance
      nil);               // pointer to window-creation data
  if (FHWindow <> 0) then
   begin
    Show(SW_HIDE);  //SW_SHOWNORMAL
    Update;
    Result:= True;
   end   else
    FErrorCode:= GetLastError;
end;

procedure TWindowObject.SetChild(Child: PWindowObject);
begin
  FChild:= Child;
end;

{ Displays the TWindowObject, after checking that it has a valid (non-zero) handle. }

procedure TWindowObject.Show(ShowCmd: Integer);
begin
  if FHWindow <> 0 then ShowWindow(FHWindow, ShowCmd);
end;

procedure TWindowObject.Update;
begin
  UpdateWindow(FHWindow);
end;

{ TMWindow }

constructor TMWindow.Create(ATitle: PChar; HParent: PWindowObject);
begin
  FTitle:= ATitle;
  inherited Create(HParent);
end;

function TMWindow.InitAttr: Bool;
begin
  with FAttr do
   begin
    Title:= FTitle;
    Style:= WS_POPUPWINDOW or WS_CAPTION or WS_MINIMIZEBOX;
    ExStyle:= 0;   //no extended styles
    X:= (GetSystemMetrics(SM_CXSCREEN) - 500) div 2;
    Y:= (GetSystemMetrics(SM_CYSCREEN) - 300) div 2;
    W:= 500;
    H:= 300;
    Param:= nil;
    Menu:= 0;      //menu handle
   end;
  Result:= True;
end;

function TMWindow.InitClass: Bool;
var  C: Bool;
     AClass: WNDCLASSEX;
     R: DWORD;
begin
  Result:= False;
  with FWndClass do