tinyapp.pas

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

     begin
      Left:= Left + 20;
      Top:= Top + 20;
      Right:= Right - 20;
      Bottom:= Bottom - 20;
     end;
    SetBkMode(FPaintDC, TRANSPARENT);
    DrawText(FPaintDC, FText, -1, ClientR, DT_LEFT or DT_NOCLIP);
   end;
end;

{ TEdit background }

constructor TEditBg.Create(AHWnd: HWND; AText:PChar);
begin
  inherited Create(AHWnd, AText);
  FHEdit:= 0;
end;

procedure TEditBg.Paint;
begin
  FHEdit:= CreateWindow(
    'EDIT',
    nil,
    WS_CHILD or WS_VISIBLE or WS_VSCROLL or ES_LEFT or ES_MULTILINE or ES_AUTOVSCROLL,
    0, 0, 0, 0,
    FHWindow,
    0,
    GetWindowLong(FHWindow, GWL_HINSTANCE),
    nil);
  if (FHEdit = 0) then
   begin
    FErrorCode:= GetLastError;
    Exit;
   end  else
   begin
    SendMessage(FHEdit, WM_SETTEXT, 0, LPARAM(FText));
    SendMessage(FHEdit, EM_SETREADONLY, 0, 0);
    ShowWindow(FHEdit, SW_SHOW);
   end;
end;

{ TTimer }

constructor TTimer.Create(AHWnd: HWND);
begin
  inherited Create;
  FHWindow:= AHWnd;
  FIDEvent:= IDT_Timer1;
  FIDSelf:= 0;
end;

destructor TTimer.Destroy;
begin
  if (FIDSelf <> 0) then  Kill;
  inherited Destroy;
end;

procedure TTimer.SetElapse(AElapse: UINT);
begin
  FIDSelf:= SetTimer(FHWindow, FIDEvent, AElapse, nil);
end;

procedure TTimer.Kill;
begin
  if (FIDSelf <> 0) then  KillTimer(FHWindow, FIDEvent);
end;

{ TMainWindow }

constructor TMainWindow.Create(ATitle: PChar);
begin
  inherited Create(nil, ATitle);
  if (FHWindow <> 0) then  FTimer:= New(PTimer, Create(FHWindow));
  if (FTimer <> nil) then  FTimer^.SetElapse(1000);
  InitBackground;
end;

destructor TMainWindow.Destroy;
begin
  if (FTimer <> nil) then  FTimer^.Free;
  if (FBackground <> nil) then  FBackground^.Free;
  inherited Destroy;
end;

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

procedure TMainWindow.InitAttr;
begin
  with FAttr do
   begin
    Style:= WS_POPUPWINDOW or WS_CAPTION or WS_MINIMIZEBOX;
    ExStyle:= 0;   //no extended styles
    X:= (GetSystemMetrics(SM_CXSCREEN) - 360) div 2;
    Y:= (GetSystemMetrics(SM_CYSCREEN) - 150) div 2;
    W:= 360;
    H:= 150;
    Param:= nil;
    Menu:= 0;      //menu handle
   end;
end;

procedure TMainWindow.InitBackground;
begin
  if (FHWindow <> 0) then
    FBackground:= New(PTextBg, Create(FHWindow, BackgroundText));
  if (FBackground <> nil) then  FBackground^.Paint;
end;

function TMainWindow.InitClass: Bool;
var   AClass: WNDCLASSEX;
begin
  Result:= False;
  with FWndClass do
   begin
    cbSize:=        sizeof(FWndClass);
    Style:=         cs_GlobalClass;
    lpfnWndProc:=   @MainWndProc;
    cbClsExtra:=    0;           //no extra class memory
    cbWndExtra:=    0;           //no extra window memory
    hInstance:=     SysInit.HInstance;
    hIcon:=         LoadIcon(hInstance, 'MainIcon');
    hCursor:=       LoadCursor(0, idc_Arrow);
    hbrBackGround:= GetStockObject(LTGray_Brush);
    lpszMenuName:=  nil;
    lpszClassName:= SuWndClassName;
    hIconSm:=       0;
   end;
    //If finds a matching class and successfully copies the data, the return value
    //is nonzero. If fails, the return value is zero.
  if not GetClassInfoEX(FWndClass.hInstance, FWndClass.lpszClassName, AClass) then
   begin
    //If succeeds, the return value is an atom that uniquely identifies the class
    //being registered. If fails, the return value is zero
    if (RegisterClassEX(FWndClass) = 0) then  FErrorCode:= GetLastError
      else  Result:= True;
   end;
end;

procedure TMainWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
begin
  if (FBackground <> nil) then  FBackground^.Paint;
end;

{ TTrayIconObject }

constructor TTrayIconObject.Create(AHWnd: HWND);
var  I: Integer;
begin
  inherited Create;
  FIconNum:= 0;
  for I:= 1 to MaxIconNum do
   begin
    FIconIDs[I].ID:= 0;
    FIconIDs[I].Used:= False;
   end;
  FNotifyIconData.cbSize:= sizeof(TNotifyIconData);
  FNotifyIconData.Wnd:= AHWnd;
end;

destructor TTrayIconObject.Destroy;
var  I: UINT;
begin
  for I:= MaxIconNum downto 1 do
    if FIconIDs[I].Used then
      Delete(FIconIDs[I].ID);
  inherited Destroy;
end;

function TTrayIconObject.Add(AuID: UINT; AHIcon: HICON; TipStr: string): Bool;
var  I, B: Integer;
     uIDUsed: Bool;
begin
  uIDUsed:= False;
  for I:= 1 to MaxIconNum do
    if FIconIDs[I].Used and (FIconIDs[I].ID = AuID) then
      uIDUsed:= True;
  if uIDUsed or (AuID = 0) or (FIconNum >= MaxIconNum) then
   begin
    Result:= False;
    Exit;
   end;
  Inc(FIconNum);
  B:= 0;
  for I:= MaxIconNum downto 1 do
    if not FIconIDs[I].Used then  B:= I;
  FIconIDs[B].ID:= AuID;
  FIconIDs[B].Used:= True;
  with FNotifyIconData do
    begin
      uID:= AuID;
      uFlags:= NIF_Icon or NIF_Tip or NIF_Message;
      uCallbackMessage:= WM_MY_CLICKICON;
      hIcon:= AHIcon;
      StrPCopy(szTip, TipStr);
    end;
  Result:= Shell_NotifyIcon(NIM_ADD, @FNotifyIconData);
end;

function TTrayIconObject.Delete(AuID: UINT): Bool;
var  I, B: Integer;
     uIDUsed: Bool;
begin
  uIDUsed:= False;
  B:= 0;
  for I:= 1 to MaxIconNum do
    if FIconIDs[I].Used and (FIconIDs[I].ID = AuID) then
     begin
      uIDUsed:= True;
      B:= I;
     end;
  if (not uIDUsed) or (AuID = 0) then
   begin
    Result:= False;
    Exit;
   end;
  FIconIDs[B].Used:= False;
  Dec(FIconNum);
  with FNotifyIconData do
    uID:= AuID;
  Result:= Shell_NotifyIcon(NIM_DELETE, @FNotifyIconData);
end;

function TTrayIconObject.Modify(AuID: UINT; AHIcon: HICON; TipStr: string): Bool;
var  I: Integer;
     uIDUsed: Bool;
begin
  uIDUsed:= False;
  for I:= 1 to MaxIconNum do
    if FIconIDs[I].Used and (FIconIDs[I].ID = AuID) then
      uIDUsed:= True;
  if (not uIDUsed) or (AuID = 0) then
   begin
    Result:= False;
    Exit;
   end;
  with FNotifyIconData do
   begin
     uID:= AuID;
     uFlags:= NIF_Icon;
     uCallbackMessage:= WM_MY_CLICKICON;
     hIcon:= AHIcon;
     if TipStr <> '' then
      begin
       StrPCopy(szTip, TipStr);
       uFlags:= uFlags or NIF_Tip;
      end;
   end;
  Result:= Shell_NotifyIcon(NIM_MODIFY, @FNotifyIconData);
end;

{ TTinyApp }

constructor TTinyApp.Create(AName: PChar);
begin
  Inherited Create;
  FAppName:= AName;
  FHInstance:= SysInit.HInstance;
  FTerminate:= False;
  FReturnValue:= 0;
  FErrorCode:= NO_ERROR;
  FTimeCounter:= 0;
  if  NotFirst then
   begin
    ShowMessage('Can not run another copy of this program!', FAppName,
      MB_OK or MB_ICONSTOP);
    FTerminate:= True;  
   end  else
   begin
    InitMainWindow;
    if (FMainWindow = nil) then
     begin
      FErrorCode:= GetLastError;
      ProcessError;
     end  else
     begin
      if (FMainWindow^.FErrorCode <> NO_ERROR) then
       begin
        FErrorCode:= FMainWindow^.FErrorCode;
        FMainWindow^.Free;
        FMainWindow:= nil;
       end  else
       begin
        InitTrayIcon;
        if (FTrayIcon = nil) then  ProcessError;
       end;
     end;
   end;
end;

destructor TTinyApp.Destroy;
begin
  if FTrayIcon <> nil then  FTrayIcon^.Free;
  if FMainWindow <> nil then  FMainWindow^.Free;         //DestroyWindow;
  inherited Destroy;
end;

function TTinyApp.DoOnStart: Bool;
begin
  Result:= True;
end;

function TTinyApp.DoOnExit: Bool;
begin
  Result:= True;
end;

procedure TTinyApp.HandleMessage;
begin
  if not ProcessMessage then  WaitMessage;
end;

{ Initializes the application's MainWindow object. }

procedure TTinyApp.InitMainWindow;
begin
  FMainWindow:= new(PMainWindow, Create(nil));
end;

procedure TTinyApp.InitTrayIcon;
begin
  FTrayIcon:= new(PTrayIconObject, Create(FMainWindow^.FHWindow));
  if (FTrayIcon = nil) then  FErrorCode:= GetLastError;
end;

function TTinyApp.NotFirst: Bool;
var
  ASecurityAttrib: SECURITY_ATTRIBUTES;
begin
  with ASecurityAttrib do
   begin
    nLength:= Sizeof(SECURITY_ATTRIBUTES);  // DWORD
    lpSecurityDescriptor:= nil;             // LPVOID
    //Windows 95: The lpSecurityDescriptor member of the structure is ignored.
    bInheritHandle:= True;                  // BOOL
   end;
  CreateMutex(@ASecurityAttrib, False, FAppName);
  //If GetLastError returns ERROR_ALREADY_EXISTS, another instance
  //of the application exists.
  Result:= (GetLastError = ERROR_ALREADY_EXISTS);
end;

procedure TTinyApp.ProcessError;
var    lpMsgBuf: LPTSTR;   //PAnsiChar
begin
  lpMsgBuf:= StrAlloc(256);
  FormatMessage(
    FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
    nil,
    FErrorCode,
    LANG_CHINESE,
    lpMsgBuf,
    0,  nil);
  ShowMessage(lpMsgBuf, 'Error', MB_OK or MB_ICONINFORMATION);
  StrDispose(lpMSgBuf);
  FTerminate:= True;
end;

function TTinyApp.ProcessMessage: Bool;
var
  AMsg: TMsg;
begin
  Result:= False;
  if PeekMessage(AMsg, FMainWindow^.FHWindow, 0, 0, PM_REMOVE) then
   begin
    Result:= True;
    case AMsg.Message of
      WM_QUIT:
        try DoOnExit finally
          FTerminate:= True;
          FReturnValue:= AMsg.wParam;
         end;
      WM_MY_PAINT:
        FMainWindow^.WMPaint(AMsg);
      WM_MY_CLOSE:
        FMainWindow^.Show(SW_HIDE);
      WM_MY_CLICKICONCALL:
        case AMsg.lParam of
          WM_LBUTTONDBLCLK:     { $0203 }
            FMainWindow^.Show(SW_SHOW);
          WM_RBUTTONDBLCLK:     { $0206 }
           begin
            if FMainWindow^.FIsShow then  Exit;
            //ShellAbout(0, AboutApp, AboutOther1, LoadIcon(FHInstance, 'MainIcon'));
            ShowMessage(AboutWndText, '□About Logbook', MB_OK or MB_ICONINFORMATION);
           end;
        end;
      WM_MY_Timer:
       begin
        Inc(FTimeCounter);
        if (FTimeCounter = 4) then  FMainWindow^.Show(SW_HIDE);
       end;
      else
       begin
        TranslateMessage(AMsg);
        DispatchMessage(AMsg);
       end;
    end;  //of case
   end;   //of if
end;

{ Runs the application. Enters message loop if initialization was successful. }

procedure TTinyApp.Run;
begin
  if not FTerminate then
   begin
    DoOnStart;
    repeat HandleMessage until FTerminate;
   end;
end;

function TTinyApp.ShowMessage(Text, Caption: PChar; Flags: Longint): Integer;
var  H: HWND;
begin
  if (FMainWindow = nil) then  H:= 0
    else  H:= FMainWindow^.FHWindow;
  Result:= MessageBoxEx(H, Text, Caption, Flags or MB_SETFOREGROUND, LANG_CHINESE);
end;

end.