tinyapp.pas

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

   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.
  C:= GetClassInfoEX(FWndClass.hInstance, FWndClass.lpszClassName, AClass);
  if not C  then
   begin
    //If succeeds, the return value is an atom that uniquely identifies the class
    //being registered. If fails, the return value is zero
    R:= RegisterClassEX(FWndClass);
    if (R = 0) then
      FErrorCode:= GetLastError() else
      Result:= True;
   end;
end;

function TMWindow.CanClose: Bool;
begin
  Result:= (FHWindow = 0) and (FChild = nil);
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_MyMessage1;
      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_MyMessage1;
     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 for TTinyApp object }

constructor TTinyApp.Create(Name: ShortString);
begin
  Inherited Create;
  FAppName:= StrAlloc(255);
  FAppName:= StrPCopy(FAppName, Name);
  FHInstance:= hInstance;
  FTerminate:= False;
  FReturnValue:= 0;
  FErrorCode:= NO_ERROR;
  FMainWindow:= CreateMainWindow;
  if (FMainWindow = nil) then
   begin
    ProcessError;
    FTerminate:= True;      Exit;
   end else
    if  NotFirst then
     begin
      ShowMessage('Can not run another copy of Logbook!', 'Stop', MB_OK or MB_ICONSTOP);
      FTerminate:= True;      Exit;
     end;
  if (FMainWindow <> nil) then FTrayIcon:= CreateTrayIcon;
  if (FTrayIcon = nil) then  ProcessError;
end;

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

function TTinyApp.CreateMainWindow: PWindowObject;
var  R: PWindowObject;
begin
  R:= new(PMWindow, Create(FAppName, nil));  // No parent
  if (R = nil) then
    FErrorCode:= GetLastError;
  Result:= R;
end;

function TTinyApp.CreateTrayIcon: PTrayIconObject;
var  R: PTrayIconObject;
begin
  Result:= nil;
  if FMainWindow <> nil then
   begin
    R:= new(PTrayIconObject, Create(FMainWindow^.FHWindow));
    if (R = nil) then
      FErrorCode:= GetLastError else
      Result:= R;
   end;
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;

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, SuWndClassName);
  //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);
end;

function TTinyApp.ProcessMessage: Bool;
var
  AMsg: TMsg;
begin
  Result:= False;
  if PeekMessage(AMsg, 0, 0, 0, PM_REMOVE) then
   begin
    Result:= True;
    case AMsg.Message of
      WM_CLOSE:
        FMainWindow^.Show(SW_HIDE);
      WM_QUIT:
        if DoOnExit then
         begin
          FTerminate:= True;
          FReturnValue:= AMsg.wParam;
         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 (FTerminate = True) then  Exit;
  if FMainWindow <> nil 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:= Windows.MessageBoxEx(H, Text, Caption, Flags or MB_SETFOREGROUND, LANG_CHINESE);
end;

end.