vrsystem.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrSystem;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ShellAPI, Menus, VrTypes, VrClasses, VrControls;


type
  TVrBitmapList = class(TVrSharedComponent)
  private
    FBitmaps: TVrBitmaps;
    FOnChange: TNotifyEvent;
    procedure SetBitmaps(Value: TVrBitmaps);
    procedure BitmapsChanged(Sender: TObject);
  protected
    procedure Changed; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetBitmap(Index: Integer): TBitmap;
  published
    property Bitmaps: TVrBitmaps read FBitmaps write SetBitmaps;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TVrStringList = class(TVrComponent)
  private
    FItems: TStrings;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    function GetCount: Integer;
    function GetSorted: Boolean;
    procedure SetItems(Value: TStrings);
    procedure SetSorted(Value: Boolean);
    procedure Change(Sender: TObject);
    procedure Changing(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Count: Integer read GetCount;
  published
    property Strings: TStrings read FItems write SetItems;
    property Sorted: Boolean read GetSorted write SetSorted default false;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;

  TVrKeyStateType = (ksNUM, ksCAPS, ksSCROLL);
  TVrKeyStateTypes = set of TVrKeyStateType;

  TVrKeyStatus = class(TVrComponent)
  private
    FHandle: HWnd;
    FMonitorEvents: Boolean;
    FKeys: TVrKeyStateTypes;
    FOnChange: TNotifyEvent;
    procedure SetKeys(Value: TVrKeyStateTypes);
    procedure SetMonitorEvents(Value: Boolean);
    procedure ChangeState(Key: Word; Active: Boolean);
    procedure UpdateTimer;
    procedure WndProc(var Msg: TMessage);
  protected
    procedure Timer;
    procedure Changed; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Keys: TVrKeyStateTypes read FKeys write SetKeys default [];
    property MonitorEvents: Boolean read FMonitorEvents write SetMonitorEvents default false;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

const  
  WM_TOOLTRAYNOTIFY = WM_USER + $44;

type
  TVrCustomTrayIcon = class(TVrComponent)
  private
    FIconData: TNOTIFYICONDATA;
    FIcon: TIcon;
    FEnabled: Boolean;
    FHint: string;
    FShowHint: Boolean;
    FVisible: Boolean;
    FPopupMenu: TPopupMenu;
    FExists: Boolean;
    FClicked: Boolean;
    FHideTaskBtn: Boolean;
    FLeftBtnPopup: Boolean;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;
    OldAppProc: Pointer;
    NewAppProc: Pointer;
    procedure SetIcon(Value: TIcon);
    procedure SetVisible(Value: Boolean);
    procedure SetHint(const Value: string);
    procedure SetShowHint(Value: Boolean);
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure ShowMenu;
    procedure UpdateHint;
    procedure UpdateSystemTray;
    procedure IconChanged(Sender: TObject);
    procedure HookApp;
    procedure UnhookApp;
    procedure HookAppProc(var Message: TMessage);
  protected
    procedure WndProc(var Msg: TMessage); virtual;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure DoHideTaskBtn;
    procedure Click; dynamic;
    procedure DblClick; dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    property Icon: TIcon read FIcon write SetIcon;
    property Visible: Boolean read FVisible write SetVisible default false;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Hint: string read FHint write SetHint;
    property ShowHint: Boolean read FShowHint write SetShowHint default false;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property HideTaskBtn: Boolean read FHideTaskBtn write FHideTaskBtn default false;
    property LeftBtnPopup: Boolean read FLeftBtnPopup write FLeftBtnPopup default false;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure HideMainForm;
    procedure ShowMainForm;
  end;

  TVrTrayIcon = class(TVrCustomTrayIcon)
  published
    property Icon;
    property Visible;
    property Enabled;
    property Hint;
    property ShowHint;
    property PopupMenu;
    property HideTaskBtn;
    property LeftBtnPopup;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
  end;

  TVrCopyErrorEvent = procedure(Sender: TObject;
    ErrorCode: Integer) of object;
  TVrOpenEvent = procedure(Sender: TObject;
    Size: Integer; Date, Time: TDateTime) of object;
  TVrOverwriteEvent = procedure(Sender: TObject;
    var Overwrite: Boolean) of object;
  TVrProgressEvent = procedure(Sender: TObject; BytesCopied: Integer;
    var Cancel: Boolean) of object;
  TVrOverwriteMode = (omAlways, omEvent);

  TVrCopyFile = class(TVrComponent)
  private
    FDestFile: string;
    FSourceFile: string;
    FBufferSize: TVrMaxInt;
    FOverwrite: TVrOverwriteMode;
    FCancel: Boolean;
    FCopyDateTime: Boolean;
    FBeforeOverwrite: TVrOverwriteEvent;
    FBeforeOpen: TVrOpenEvent;
    FOnProgress: TVrProgressEvent;
    FAfterCopy: TNotifyEvent;
  protected
    function CheckExists: Boolean;
    function CheckOverwrite: Boolean;
    procedure DoProgress(BytesCopied: Integer; var Cancel: Boolean);
    procedure DoAfterCopy;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Terminate;
  published
    property DestFile: string read FDestFile write FDestFile;
    property SourceFile: string read FSourceFile write FSourceFile;
    property BufferSize: TVrMaxInt read FBufferSize write FBufferSize default 1024;
    property Overwrite: TVrOverwriteMode read FOverwrite write FOverwrite default omAlways;
    property CopyDateTime: Boolean read FCopyDateTime write FCopyDateTime;
    property BeforeOverwrite: TVrOverwriteEvent read FBeforeOverwrite write FBeforeOverwrite;
    property BeforeOpen: TVrOpenEvent read FBeforeOpen write FBeforeOpen;
    property OnProgress: TVrProgressEvent read FOnProgress write FOnProgress;
    property AfterCopy: TNotifyEvent read FAfterCopy write FAfterCopy;
  end;

  TVrLocateEvent = procedure(Sender: TObject; Path: string;
    SearchRec: TSearchRec; var Cancel: Boolean) of object;
  TVrDirScan = class(TVrComponent)
  private
    FMask: string;
    FPath: string;
    FRecursive: Boolean;
    FCancel: Boolean;
    FScanning: Boolean;
    FOnLocate: TVrLocateEvent;
    FOnNotify: TNotifyEvent;
  protected
    procedure Notify;
    procedure LocateFile(Path: string; SearchRec: TSearchRec);
    procedure Scan(Path, Mask: string; Recurse: Boolean);
    function AbortScan: Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Cancel;
  published
    property Mask: string read FMask write FMask;
    property Path: string read FPath write FPath;
    property Recursive: Boolean read FRecursive write FRecursive default True;
    property OnLocate: TVrLocateEvent read FOnLocate write FOnLocate;
    property OnNotify: TNotifyEvent read FOnNotify write FOnNotify;
  end;


implementation

{ TVrBitmapList }

constructor TVrBitmapList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitmaps := TVrBitmaps.Create;
  FBitmaps.OnChange := BitmapsChanged;
end;

destructor TVrBitmapList.Destroy;
begin
  FBitmaps.Free;
  inherited Destroy;
end;

procedure TVrBitmapList.SetBitmaps(Value: TVrBitmaps);
begin
  FBitmaps.Assign(Value);
end;

function TVrBitmapList.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if (Index > -1) and (Index < Bitmaps.Count) then
    Result := Bitmaps[Index];
end;

procedure TVrBitmapList.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrBitmapList.BitmapsChanged(Sender: TObject);
begin
  NotifyClients;
  Changed;
end;

{ TVrStringList }

constructor TVrStringList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FItems := TStringList.Create;
  TStringList(FItems).OnChange := Change;
  TStringList(FItems).OnChanging := Changing;
end;

destructor TVrStringList.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

procedure TVrStringList.SetItems(Value: TStrings);
begin
  FItems.Assign(Value);
end;

function TVrStringList.GetSorted: Boolean;
begin
  Result := TStringList(FItems).Sorted;
end;

function TVrStringList.GetCount: Integer;
begin
  Result := FItems.Count;
end;

procedure TVrStringList.SetSorted(Value: Boolean);
begin
  TStringList(FItems).Sorted := Value;
end;

procedure TVrStringList.Change(Sender: TObject);
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrStringList.Changing(Sender: TObject);
begin
  if Assigned(FOnChanging) then FOnChanging(Self);
end;

{ TVrKeyStatus }

constructor TVrKeyStatus.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FKeys := [];
  FMonitorEvents := false;
  FHandle := AllocateHWnd(WndProc);
end;

destructor TVrKeyStatus.Destroy;
begin
  FMonitorEvents := false;
  UpdateTimer;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TVrKeyStatus.WndProc(var Msg: TMessage);
begin
  with Msg do
    if Msg = WM_TIMER then
      try
        Timer;
      except
        Application.HandleException(Self);
      end
    else
      Result := DefWindowProc(FHandle, Msg, wParam, lParam);
end;

procedure TVrKeyStatus.UpdateTimer;
begin
  KillTimer(FHandle, 1);
  if MonitorEvents then
    if SetTimer(FHandle, 1, 100, nil) = 0 then
      raise EOutOfResources.Create('Out of resources.');
end;

procedure TVrKeyStatus.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrKeyStatus.Timer;
var
  Current: Integer;
  NewKeys: TVrKeyStateTypes;
begin
  NewKeys := [];
  Current := GetKeyState(VK_NUMLOCK);
  if Current <> 0 then NewKeys := NewKeys + [ksNUM];
  Current := GetKeyState(VK_CAPITAL);
  if Current <> 0 then NewKeys := NewKeys + [ksCAPS];
  Current := GetKeyState(VK_SCROLL);
  if Current <> 0 then NewKeys := NewKeys + [ksSCROLL];
  if not (csDesigning in ComponentState) then
    if Keys <> NewKeys then
    begin
      FKeys := NewKeys;
      Changed;
    end;
end;

procedure TVrKeyStatus.ChangeState(Key: Word; Active: Boolean);
var
  Current: Integer;
  KeyState: TKeyBoardState;
begin
  Current := GetKeyState(Key);
  GetKeyboardState(KeyState);
  if (Current = 0) and (Active) then
  begin
    KeyState[Key] := 1;
    SetKeyboardState(KeyState);
  end
  else
  if (not Active) then
  begin
    KeyState[Key] := 0;
    SetKeyboardState(KeyState);
  end;
end;

procedure TVrKeyStatus.SetMonitorEvents(Value: Boolean);
begin
  if FMonitorEvents <> Value then
  begin
    FMonitorEvents := Value;
    UpdateTimer;
  end;
end;

procedure TVrKeyStatus.SetKeys(Value: TVrKeyStateTypes);
const
  KeyValues: array[TVrKeyStateType] of Word =
    (VK_NUMLOCK, VK_CAPITAL, VK_SCROLL);
var
  I: TVrKeyStateType;
begin
  if FKeys <> Value then
  begin
    FKeys := Value;
    for I := Low(TVrKeyStateType) to High(TVrKeyStateType) do
      ChangeState(KeyValues[I], I in Value);
    Changed;
  end;
end;

{ TVrCustomTrayIcon }

constructor TVrCustomTrayIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FEnabled := True;
  FVisible := false;
  FExists := false;
  FShowHint := false;
  FLeftBtnPopup := false;
  FHideTaskBtn := false;
  with FIconData do
  begin
    cbSize := SizeOf(TNOTIFYICONDATA);
    Wnd := AllocateHWnd(WndProc);
    uID := 0;
    uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
    uCallbackMessage := WM_TOOLTRAYNOTIFY;
  end;
  HookApp;
end;

destructor TVrCustomTrayIcon.Destroy;
begin
  Visible := false;
  FIcon.Free;
  DeallocateHWnd(FIconData.Wnd);
  UnhookApp;
  inherited Destroy;
end;

procedure TVrCustomTrayIcon.HookApp;
begin
  if not (csDesigning in ComponentState) then
  begin
    OldAppProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
    NewAppProc := MakeObjectInstance(HookAppProc);
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(NewAppProc));
  end;