tinyapp.pas

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

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

Unit TinyApp;

{$R-}

Interface

uses
  SysUtils, Windows, Messages, ShellAPI, SuObject;

const
  MaxIconNum  = 10;
  IDI_MyFirst = 17;
  IDT_Timer1  = 1;
  SuWndClassName: PChar = 'SucxWindow';

{ TMainWindow background codes}
  bg_Bitmap   = 1;
  bg_Text     = 2;
  bg_Edit     = 3;

type

{ TWindowObject creation attributes }

  TWindowAttr = record
    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;
    FTitle: PChar;
    FAttr: TWindowAttr;
    FWndClass: WNDCLASSEX;
    FParent,
    FChild: PWindowObject;
    FErrorCode: DWORD;
    FIsShow: Bool;
    constructor Create(HParent: PWindowObject; ATitle: PChar);
    destructor Destroy; virtual;
    function Enable(AStatus: Bool): Bool;
    procedure Focus;
    function GetClassName: PChar; virtual;
    procedure InitAttr; virtual;
    function InitClass: Bool; virtual;
    procedure InitWindow;
    procedure SetChild(Child: PWindowObject);
    procedure Show(ShowCmd: Integer);
    procedure Update;
    procedure WMPaint(var Msg: TMsg); virtual;
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
   end;

{ TBackgroundObject }

  PBackgroundObject = ^TBackgroundObject;
  TBackgroundObject = object(TSObject)
    FHWindow: HWND;
    FText: PChar;
    FErrorCode: DWORD;
    constructor Create(AHWnd: HWND; AText: PChar);
    procedure Paint; virtual;
   end;

{ TBitmap background }

  PBitmapBg = ^TBitmapBg;
  TBitmapBg = object(TBackgroundObject)
    FBitmap: HBITMAP;
    constructor Create(AHWnd: HWND; AName: LPCTSTR);
    destructor Destroy; virtual;
    procedure Paint; virtual;
   end;

{ TText background }

  PTextBg = ^TTextBg;
  TTextBg = object(TBackgroundObject)
    FPaintDC: HDC;
    FMetrics: TEXTMETRIC;
    constructor Create(AHWnd: HWND; AText: PChar);
    procedure Paint; virtual;
   end;

{ TEdit background }

  PEditBg = ^TEditBg;
  TEditBg = object(TBackgroundObject)
    FHEdit: HWND;
    constructor Create(AHWnd: HWND; AText: PChar);
    procedure Paint; virtual;
   end;

{ TTimer }

  PTimer = ^TTimer;
  TTimer = object(TSObject)
    FHWindow: HWND;
    FIDEvent,
    FIDSelf: UINT;
    constructor Create(AHWnd: HWND);
    destructor Destroy; virtual;
    procedure SetElapse(AElapse: UINT);
    procedure Kill;
   end;

{ TMainWindow - Main Window }

  PMainWindow = ^TMainWindow;
  TMainWindow = object(TWindowObject)
    FTimer: PTimer;
    FBackground: PBackgroundObject;
    constructor Create(ATitle: PChar);
    destructor Destroy; virtual;
    procedure InitAttr; virtual;
    procedure InitBackground; virtual;
    function InitClass: Bool; virtual;
    function GetClassName: PChar; virtual;
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
   end;

{ TTrayIconObject - Tray icon object }

  IDRec = record
    ID: UINT;           // UINT = LongWord;
    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;      // HINST = type LongWord;
    FMainWindow: PWindowObject;
    FTrayIcon: PTrayIconObject;
    FTerminate: Bool;
    FReturnValue: Integer;
    FErrorCode: DWORD;
    Status: Integer;
    constructor Create(AName: PChar);
    destructor Destroy; virtual;
    function DoOnStart: Bool; virtual;
    function DoOnExit: Bool; virtual;
    procedure HandleMessage;
    procedure InitMainWindow; virtual;
    procedure InitTrayIcon; virtual;
    function NotFirst: Bool;
    procedure ProcessError;
    function ProcessMessage: Bool;
    procedure Run; virtual;
    function ShowMessage(Text, Caption: PChar; Flags: Longint): Integer;
   private
    FTimeCounter: DWORD;
  end;

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

Implementation

const
  QUIT_ERROR          = 0;
  QUIT_CLOSE          = 1;
  QUIT_END            = 2;
  
  AboutWndText: PChar = '  Logbook v1.0'#13#10#13#10'欢迎使用,版权保留       ' +
                #13#10#13#10'2000, 苏成翔,王峰       ';
  AboutApp: LPCTSTR = '□关于Logbook#Logbook v1.0'#13#10'版权所有(c) 2000-2001 苏成翔,王峰';
  AboutOther1: LPCTSTR = '欢迎您使用Logbook v1.0!'#13#10#13#10'本程序未经注册。请您注册:' +
    #13#10#13#10'兰州市27支局15信箱13号(732750)'#13#10'Tel:[phone](O) 2467250(H)';
  AboutOther2: LPCTSTR = '感谢您使用Logbook v1.0!'#13#10#13#10'如有问题或建议,请联系:' +
    #13#10#13#10'兰州市27支局15信箱13号(732750)'#13#10'Tel:[phone](O) 2467250(H)';
  BackgroundText: PChar =
    '欢迎您使用Logbook!'#13#10#13#10 +
    '测试版(v1.0).如发现此程序有问题,请联系:'#13#10 +
    '苏成翔, Tel:[phone]'#13#10 +
    '兰州市27支局15信箱13号(732750)';

function MainWndProc(AhWnd: HWND; AMessage: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
StdCall; export;
begin
  case AMessage of
    WM_DESTROY:               { $0002 }
      begin
       //PostQuitMessage(QUIT_CLOSE);
       Result:= 1;
      end;
    WM_PAINT:
      begin
       PostMessage(AhWnd, WM_MY_PAINT, wParam, lParam);
       Result:= 0;
      end;
    { If an application processes this message, it should return zero. }
    WM_CLOSE:
      begin
       PostMessage(AhWnd, WM_MY_CLOSE, wParam, lParam);
       //ShowWindow(AhWnd, SW_HIDE);
       Result:= 1;
      end;
    { If an application can terminate conveniently, it should return TRUE;
      otherwise, it should return FALSE.}
    WM_QUERYENDSESSION:            // $0011
      begin                        // posts a WM_QUIT message to the app's message
       PostQuitMessage(QUIT_END);  // queue and returns immediately
       Result:= 1;
      end;
    WM_TIMER:
      begin
       PostMessage(AhWnd, WM_MY_TIMER, wParam, lParam);
       Result:= 0;
      end;
    WM_MY_CLICKICON:
      begin
       PostMessage(AhWnd, WM_MY_CLICKICONCALL, wParam, lParam);
       Result:= 0;
      end;
   else
    Result:= DefWindowProc(AhWnd, AMessage, wParam, lParam);
  end;
end;

{ TWindowObject }

constructor TWindowObject.Create(HParent: PWindowObject; ATitle: PChar);
begin
  inherited Create;
  FHWindow:= 0;
  FParent:= HParent;
  FChild:= nil;
  FTitle:= ATitle;
  FErrorCode:= NO_ERROR;
  InitWindow;
end;

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

{ Enable or disable the window }

function TWindowObject.Enable(AStatus: Bool): Bool;
begin
  if (FHWindow <> 0) then Result:= EnableWindow(FHWindow, AStatus)
    else Result:= False;
end;

{ Focus the window }

procedure TWindowObject.Focus;
begin
  if FHWindow <> 0 then SetFocus(FHWindow);
end;

function TWindowObject.GetClassName: PChar;
begin
  Result:= 'WindowObjectClass';
end;

procedure TWindowObject.InitAttr;
begin
end;

function TWindowObject.InitClass: Bool;
begin
  Result:= False;
end;

procedure TWindowObject.InitWindow;
var  Parent: HWND;
begin
  InitAttr;
  if not InitClass then  Exit;
  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
      FWndClass.lpszClassName,   // pointer to registered class name
      FTitle,         // 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
      FWndClass.hInstance, // handle to application instance
      nil);                // pointer to window-creation data
  if (FHWindow <> 0) then  Show(SW_SHOWNORMAL)  //SW_SHOWNORMAL
    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  Exit;
  if (ShowCmd = SW_HIDE) then  FIsShow:= False  else  FIsShow:= True;
  ShowWindow(FHWindow, ShowCmd);
  if (ShowCmd = SW_SHOWNORMAL) or (ShowCmd = SW_SHOW) then
    SetForegroundWindow(FHWindow);
  Update;
end;

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

{ Response method for an incoming wm_Paint message. }

procedure TWindowObject.WMPaint(var Msg: TMsg);
var
  PaintInfo: TPaintStruct;
begin
  BeginPaint(FHWindow, PaintInfo);
  Paint(PaintInfo.HDC, PaintInfo);
  EndPaint(FHWindow, PaintInfo);
end;

{ Redraws the contents of the TWindow after a WMPaint message is received.
  Placeholder for descendant object types to redefine. }

procedure TWindowObject.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
begin
end;

{ TBackgroundObject }

constructor TBackgroundObject.Create(AHWnd: HWND; AText: PChar);
begin
  inherited Create;
  FHWindow:= AHWnd;
  FText:= AText;
end;

procedure TBackgroundObject.Paint;
begin
end;

{ TBitmap background }

constructor TBitmapBg.Create(AHWnd: HWND; AName: LPCTSTR);
begin
  inherited Create(AHWnd, AName);
  FBitmap:= LoadBitmap(HInstance, AName);
end;

destructor TBitmapBg.Destroy;
begin
  if (FBitmap <> 0) then  DeleteObject(FBitmap);
  inherited Destroy;
end;

procedure TBitmapBg.Paint;
var  MemDC, WndDC: HDC;
     OldBitmap: HBITMAP;
     ClientR: TRect;
begin
  WndDC:= GetDC(FHWindow);
  MemDC:= CreateCompatibleDC(WndDC);
  OldBitmap:= SelectObject(MemDC, FBitmap);
  GetClientRect(FHWindow, ClientR);
  with ClientR do
    BitBlt(WndDC, Left, Top, Right, Bottom, MemDC, 0, 0, SRCCOPY);
  ReleaseDC(FHWindow, WndDC);
  SelectObject(MemDC, OldBitmap);
  DeleteDC(MemDC);
end;

{ TText background }

constructor TTextBg.Create(AHWnd: HWND; AText: PChar);
begin
  inherited Create(AHWnd, AText);
  FPaintDC:= GetDC(FHWindow);
  if GetTextMetrics(FPaintDC, FMetrics) then  FErrorCode:= NO_ERROR
    else FErrorCode:= GetLastError;
end;

procedure TTextBg.Paint;
var  ClientR: TRect;
begin
  if (FErrorCode = NO_ERROR) then
   begin
    GetClientRect(FHWindow, ClientR);
    with ClientR do