rxshell.pas

企业端数据申报系统：单位管理模块 单位查询. 业务申报模块 在线数据下载 在线数据上传 在线业务申核 申报业务查询 磁盘数据导出 磁盘数据导入 在线业务模块 在线业务

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997 Master-Bank                }
{                                                       }
{*******************************************************}

{.$DEFINE USE_TIMER}
{ - Use Windows timer instead thread to the animated TrayIcon }

{$IFNDEF WIN32}
  {$DEFINE USE_TIMER}  { - Always use timer in 16-bit version }
{$ENDIF}

unit RXShell;

{$I RX.INC}
{$P+,W-,R-}

interface

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Messages,
  Classes, Graphics, SysUtils, Forms, Controls, Menus, ShellAPI,
  {$IFDEF USE_TIMER} ExtCtrls, {$ENDIF} IcoList;

type
{$IFNDEF WIN32}
  PNotifyIconData = ^TNotifyIconData;
  TNotifyIconData = record
    cbSize: Longint;
    Wnd: Longint;
    uID: Longint;
    uFlags: Longint;
    uCallbackMessage: Longint;
    hIcon: Longint;
    szTip: array [0..63] of Char;
  end;
{$ENDIF}

  TMouseButtons = set of TMouseButton;

{ TRxTrayIcon }

  TRxTrayIcon = class(TComponent)
  private
    FHandle: HWnd;
    FActive: Boolean;
    FAdded: Boolean;
    FAnimated: Boolean;
    FEnabled: Boolean;
    FClicked: TMouseButtons;
    FIconIndex: Integer;
    FInterval: Word;
    FIconData: TNotifyIconData;
    FIcon: TIcon;
    FIconList: TIconList;
{$IFDEF USE_TIMER}
    FTimer: TTimer;
{$ELSE}
    FTimer: TThread;
{$ENDIF}
    FHint: string;
    FShowDesign: Boolean;
    FPopupMenu: TPopupMenu;
    FOnClick: TMouseEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    procedure ChangeIcon;
{$IFDEF USE_TIMER}
    procedure Timer(Sender: TObject);
{$ELSE}
    procedure Timer;
{$ENDIF}
    procedure SendCancelMode;
    function CheckMenuPopup(X, Y: Integer): Boolean;
    function CheckDefaultMenuItem: Boolean;
    procedure SetHint(const Value: string);
    procedure SetIcon(Value: TIcon);
    procedure SetIconList(Value: TIconList);
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure Activate;
    procedure Deactivate;
    procedure SetActive(Value: Boolean);
    function GetAnimated: Boolean;
    procedure SetAnimated(Value: Boolean);
    procedure SetShowDesign(Value: Boolean);
    procedure SetInterval(Value: Word);
    procedure IconChanged(Sender: TObject);
    procedure WndProc(var Message: TMessage);
    function GetActiveIcon: TIcon;
  protected
    procedure DblClick; dynamic;
    procedure DoClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure UpdateNotifyData; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Hide;
    procedure Show;
    property Handle: HWnd read FHandle;
  published
    property Active: Boolean read FActive write SetActive default True;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Hint: string read FHint write SetHint;
    property Icon: TIcon read FIcon write SetIcon;
    property Icons: TIconList read FIconList write SetIconList;
    { Ensure Icons is declared before Animated }
    property Animated: Boolean read GetAnimated write SetAnimated default False;
    property Interval: Word read FInterval write SetInterval default 150;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property ShowDesign: Boolean read FShowDesign write SetShowDesign stored False;
    property OnClick: TMouseEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;

function IconExtract(const FileName: string; Id: Integer): TIcon;
procedure WinAbout(const AppName, Stuff: string);

type
  TExecState = (esNormal, esMinimized, esMaximized, esHidden);

function FileExecute(const FileName, Params, StartDir: string;
  InitialState: TExecState): THandle;
function FileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;

implementation

uses RxConst, RxCConst, VCLUtils, MaxMin;

{$IFNDEF WIN32}
const
  Shell = 'shell';

function ExtractAssociatedIcon(hInst: THandle; lpIconPath: PChar;
  var lpiIcon: Word): HIcon; far; external Shell;
function ShellAbout(Wnd: HWnd; App, Stuff: PChar; Icon: HIcon): Integer;
  far; external Shell;
{$ENDIF WIN32}

procedure WinAbout(const AppName, Stuff: string);
var
{$IFNDEF WIN32}
  szApp, szStuff: array[0..255] of Char;
{$ENDIF}
  Wnd: HWnd;
  Icon: HIcon;
begin
  if Application.MainForm <> nil then Wnd := Application.MainForm.Handle
  else Wnd := 0;
  Icon := Application.Icon.Handle;
  if Icon = 0 then Icon := LoadIcon(0, IDI_APPLICATION);
{$IFDEF WIN32}
  ShellAbout(Wnd, PChar(AppName), PChar(Stuff), Icon);
{$ELSE}
  StrPLCopy(szApp, AppName, SizeOf(szApp) - 1);
  StrPLCopy(szStuff, Stuff, SizeOf(szStuff) - 1);
  ShellAbout(Wnd, szApp, szStuff, Icon);
{$ENDIF}
end;

function IconExtract(const FileName: string; Id: Integer): TIcon;
var
  S: array[0..255] of char;
  IconHandle: HIcon;
  Index: Word;
begin
  Result := TIcon.Create;
  try
    StrPLCopy(S, FileName, SizeOf(S) - 1);
    IconHandle := ExtractIcon(hInstance, S, Id);
    if IconHandle < 2 then begin
      Index := Id;
      IconHandle := ExtractAssociatedIcon(hInstance, S, Index);
    end;
    if IconHandle < 2 then begin
      if IconHandle = 1 then
        raise EResNotFound.Create(LoadStr(SFileNotExec))
      else begin
        Result.Free;
        Result := nil;
      end;
    end else Result.Handle := IconHandle;
  except
    Result.Free;
    raise;
  end;
end;

const
  ShowCommands: array[TExecState] of Integer =
    (SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED, SW_HIDE);

function FileExecute(const FileName, Params, StartDir: string;
  InitialState: TExecState): THandle;
{$IFDEF WIN32}
begin
  Result := ShellExecute(Application.Handle, nil, PChar(FileName),
    PChar(Params), PChar(StartDir), ShowCommands[InitialState]);
end;
{$ELSE}
var
  cFileName, cParams, cPath: array [0..80] of Char;
begin
  Result := ShellExecute(Application.Handle, nil, StrPCopy(cFileName,
    FileName), StrPCopy(cParams, Params), StrPCopy(cPath, StartDir),
    ShowCommands[InitialState]);
end;
{$ENDIF}

function FileExecuteWait(const FileName, Params, StartDir: string;
  InitialState: TExecState): Integer;
{$IFDEF WIN32}
var
  Info: TShellExecuteInfo;
  ExitCode: DWORD;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.cbSize := SizeOf(TShellExecuteInfo);
  with Info do begin
    fMask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := Application.Handle;
    lpFile := PChar(FileName);
    lpParameters := PChar(Params);
    lpDirectory := PChar(StartDir);
    nShow := ShowCommands[InitialState];
  end;
  if ShellExecuteEx(@Info) then begin
    repeat
      Application.ProcessMessages;
      GetExitCodeProcess(Info.hProcess, ExitCode);
    until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
    Result := ExitCode;
  end
  else Result := -1;
end;
{$ELSE}
var
  Task: THandle;
begin
  Result := 0;
  Task := FileExecute(FileName, Params, StartDir, InitialState);
  if Task >= HINSTANCE_ERROR then begin
    repeat
      Application.ProcessMessages;
    until (GetModuleUsage(Task) = 0) or Application.Terminated;
  end
  else Result := -1;
end;
{$ENDIF}

{$IFNDEF USE_TIMER}

{ TTimerThread }

type
  TTimerThread = class(TThread)
  private
    FOwnerTray: TRxTrayIcon;
  protected
    procedure Execute; override;
  public
    constructor Create(TrayIcon: TRxTrayIcon; CreateSuspended: Boolean);
  end;

constructor TTimerThread.Create(TrayIcon: TRxTrayIcon; CreateSuspended: Boolean);
begin
  FOwnerTray := TrayIcon;
  inherited Create(CreateSuspended);
  FreeOnTerminate := True;
end;

procedure TTimerThread.Execute;

  function ThreadClosed: Boolean;
  begin
    Result := Terminated or Application.Terminated or (FOwnerTray = nil);
  end;

begin
  while not Terminated do begin
    if not ThreadClosed then
      if SleepEx(FOwnerTray.FInterval, False) = 0 then begin
        if not ThreadClosed and FOwnerTray.Animated then
          FOwnerTray.Timer;
      end;
  end;
end;

{$ENDIF USE_TIMER}

{$IFNDEF WIN32}

type
  TLoadLibrary32 = function (FileName: PChar; Handle, Special: Longint): Longint;
  TFreeLibrary32 = function (Handle: Longint): Bool;
  TGetAddress32 = function (Handle: Longint; ProcName: PChar): Pointer;
  TCallProc32 = function (Msg: Longint; Data: PNotifyIconData; ProcHandle: Pointer;
    AddressConvert, Params: Longint): Longint;

const
  NIM_ADD     = $00000000;
  NIM_MODIFY  = $00000001;
  NIM_DELETE  = $00000002;

  NIF_MESSAGE = $00000001;
  NIF_ICON    = $00000002;
  NIF_TIP     = $00000004;

const
  Shell32: Longint = 0;
  ProcAddr: Pointer = nil;
  FreeLib32: TFreeLibrary32 = nil;
  CallPrc32: TCallProc32 = nil;

procedure FreeHandles; far;
begin
  if (ProcAddr <> nil) and Assigned(FreeLib32) then FreeLib32(Shell32);
end;

procedure InitHandles;
var
  Kernel16: THandle;
  LoadLib32: TLoadLibrary32;
  GetAddr32: TGetAddress32;
begin
  Kernel16 := GetModuleHandle('kernel');
  @LoadLib32 := GetProcAddress(Kernel16, 'LoadLibraryEx32W');
  @FreeLib32 := GetProcAddress(Kernel16, 'FreeLibrary32W');
  @GetAddr32 := GetProcAddress(Kernel16, 'GetProcAddress32W');
  @CallPrc32 := GetProcAddress(Kernel16, 'CallProc32W');
  if (@LoadLib32 <> nil) and (@FreeLib32 <> nil) and (@GetAddr32 <> nil)
    and (@CallPrc32 <> nil) then
  begin
    Shell32 := LoadLib32('shell32', 0, 0);
    if Shell32 >= HINSTANCE_ERROR then begin
      ProcAddr := GetAddr32(Shell32, 'Shell_NotifyIcon');
      if ProcAddr = nil then begin
        FreeLib32(Shell32);
        Shell32 := 1;
      end
      else AddExitProc(FreeHandles);
    end
    else Shell32 := 1;
  end;
end;

function Shell_NotifyIcon(dwMessage: Longint; lpData: PNotifyIconData): Bool;
begin
  if (ProcAddr = nil) and (Shell32 <> 1) then InitHandles;
  if ProcAddr <> nil then
    Result := Bool(CallPrc32(dwMessage, lpData, ProcAddr, $01, 2));
end;

{$ENDIF WIN32}

{ TRxTrayIcon }

constructor TRxTrayIcon.Create(AOwner: Tcomponent);
begin
  inherited Create(AOwner);
  FHandle := Classes.AllocateHWnd(WndProc);
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FIconList := TIconList.Create;
  FIconList.OnChange := IconChanged;
  FIconIndex := -1;
  FEnabled := True;
  FInterval := 150;
  FActive := True;
end;

destructor TRxTrayIcon.Destroy;
begin
  Destroying;
  FEnabled := False;
  FIconList.OnChange := nil;
  FIcon.OnChange := nil;
  SetAnimated(False);
  Deactivate;
  Classes.DeallocateHWnd(FHandle);
  FIcon.Free;