Delphi控件源码

开发平台：
Delphi

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;
end;
procedure TVrCustomTrayIcon.UnhookApp;
begin
  if not (csDesigning in ComponentState) then
  begin
    if Assigned(OldAppProc) then
      SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldAppProc));
    if Assigned(NewAppProc) then
      FreeObjectInstance(NewAppProc);
    NewAppProc := nil;
    OldAppProc := nil;
  end;
end;
procedure TVrCustomTrayIcon.HookAppProc(var Message: TMessage);
begin
  with Message do
  begin
    case Msg of
      WM_SIZE:
        if wParam = SIZE_MINIMIZED then
        begin
          if FHideTaskBtn then
            DoHideTaskBtn;
        end;
    end;
    Result := CallWindowProc(OldAppProc, Application.Handle, Msg, wParam, lParam);
  end;
end;
procedure TVrCustomTrayIcon.DoHideTaskBtn;
begin
  HideMainForm;
  Visible := True;
end;
procedure TVrCustomTrayIcon.ShowMainForm;
begin
  ShowWindow(Application.Handle, SW_RESTORE);
  ShowWindow(Application.MainForm.Handle, SW_RESTORE);
end;
procedure TVrCustomTrayIcon.HideMainForm;
begin
  ShowWindow(Application.Handle, SW_HIDE);
  ShowWindow(Application.MainForm.Handle, SW_HIDE);
end;
procedure TVrCustomTrayIcon.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  Value.FreeNotification(Self);
end;
procedure TVrCustomTrayIcon.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FPopupMenu) then
    FPopupMenu := nil;
end;
procedure TVrCustomTrayIcon.IconChanged(Sender: TObject);
begin
  UpdateSystemTray;
end;
procedure TVrCustomTrayIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
end;
procedure TVrCustomTrayIcon.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    UpdateSystemTray;
  end;
end;
procedure TVrCustomTrayIcon.SetHint(const Value: string);
begin
  if FHint <> Value then
  begin
    FHint := Value;
    UpdateHint;
  end;
end;
procedure TVrCustomTrayIcon.SetShowHint(Value: Boolean);
begin
  if FShowHint <> Value then
  begin
    FShowHint := Value;
    UpdateHint;
  end;
end;
procedure TVrCustomTrayIcon.UpdateHint;
begin
  if (FHint <> '') and FShowHint then
    StrLCopy(FIconData.szTip, PChar(FHint), SizeOf(FIconData.szTip))
  else FIconData.szTip := '';
  UpdateSystemTray;
end;
procedure TVrCustomTrayIcon.UpdateSystemTray;
begin
  if (FIcon.Empty) or
    (csDesigning in ComponentState) then Exit;
  if (not Visible) and (FExists) then
  begin
    Shell_NotifyIcon(NIM_DELETE, @FIconData);
    FExists := false;
    Exit;
  end;
  if FVisible then
  begin
    FIconData.hIcon := FIcon.Handle;
    if (not FExists) then
    begin
      Shell_NotifyIcon(NIM_ADD, @FIconData);
      FExists := True;
    end else Shell_NotifyIcon(NIM_MODIFY, @FIconData);
  end;
end;
procedure TVrCustomTrayIcon.WndProc(var Msg: TMessage);
  function ShiftState: TShiftState;
  begin
    Result := [];
    if GetKeyState(Vk_Shift) < 0 then Include(Result, ssShift);
    if GetKeyState(Vk_Control) < 0 then Include(Result, ssCtrl);
    if GetKeyState(Vk_Menu) < 0 then Include(Result, ssAlt);
  end;
var
  P: TPoint;
  Shift: TShiftState;
begin
  with Msg do
    if Msg = WM_TOOLTRAYNOTIFY then
    begin
      case lParam of
        WM_MOUSEMOVE:
          if Enabled then
          begin
            Shift := ShiftState;
            GetCursorPos(P);
            MouseMove(Shift, P.X, P.Y);
          end;
        WM_LBUTTONDOWN:
          if Enabled then
          begin
            Shift := ShiftState + [ssLeft];
            GetCursorPos(P);
            MouseDown(mbLeft, Shift, P.X, P.Y);
            FClicked := True;
            if FLeftBtnPopup then
            begin
              FClicked := false;
              ShowMenu;
            end;
          end;
        WM_LBUTTONUP:
          if Enabled then
          begin
            Shift := ShiftState + [ssLeft];
            GetCursorPos(P);
            if FClicked then
            begin
              FClicked := False;
              Click;
            end;
            MouseUp(mbLeft, Shift, P.X, P.Y);
          end;
        WM_LBUTTONDBLCLK:
          if Enabled then DblClick;
        WM_RBUTTONDOWN:
          if Enabled then
          begin
            Shift := ShiftState + [ssRight];
            GetCursorPos(P);
            MouseDown(mbRight, Shift, P.X, P.Y);
            ShowMenu;
          end;
        WM_RBUTTONUP:
          if Enabled then
          begin
            Shift := ShiftState + [ssRight];
            GetCursorPos(P);
            MouseUp(mbRight, Shift, P.X, P.Y);
          end;
        WM_RBUTTONDBLCLK:
          if Enabled then DblClick;
        WM_MBUTTONDOWN:
          if Enabled then
          begin
            Shift := ShiftState + [ssMiddle];
            GetCursorPos(P);
            MouseDown(mbMiddle, Shift, P.X, P.Y);
          end;
        WM_MBUTTONUP:
          if Enabled then
          begin
            Shift := ShiftState + [ssMiddle];
            GetCursorPos(P);
            MouseUp(mbMiddle, Shift, P.X, P.Y);
          end;
        WM_MBUTTONDBLCLK:
          if Enabled then DblClick;
      end
    end else Result := DefWindowProc(FIconData.Wnd, Msg, wParam, lParam);
end;
procedure TVrCustomTrayIcon.ShowMenu;
var
  P: TPoint;
begin
  if (PopupMenu <> nil) then
  begin
    GetCursorPos(P);
    Application.ProcessMessages;
    SetForegroundWindow(Application.MainForm.Handle);
    PopupMenu.Popup(P.X, P.Y);
    PostMessage(Application.MainForm.Handle, WM_NULL, 0, 0);
  end;
end;
procedure TVrCustomTrayIcon.Click;
begin
  if Assigned(FOnClick) then FOnClick(Self);
end;
procedure TVrCustomTrayIcon.DblClick;
begin
  if Assigned(FOnDblClick) then FOnDblClick(Self);
end;
procedure TVrCustomTrayIcon.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
end;
procedure TVrCustomTrayIcon.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseUp) then
    FOnMouseUp(Self, Button, Shift, X, Y);
end;
procedure TVrCustomTrayIcon.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then
    FOnMouseMove(Self, Shift, X, Y);
end;
{ TVrCopyFile }
constructor TVrCopyFile.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBufferSize := 1024;
  FOverwrite := omAlways;
  FCopyDateTime := True;
end;
destructor TVrCopyFile.Destroy;
begin
  Terminate;
  inherited Destroy;
end;
function TVrCopyFile.CheckExists: Boolean;
var
  SearchRec: TSearchRec;
begin
  Result := FindFirst(ExpandFileName(SourceFile), faAnyFile, SearchRec) = 0;
  try
    if Result then
    begin
      with SearchRec do
        if Assigned(FBeforeOpen) then FBeforeOpen(Self, Size, Date, Time);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;
function TVrCopyFile.CheckOverwrite: Boolean;
begin
  Result := (Overwrite = omAlways);
  if not Result then
  begin
    Result := True;
    if FileExists(DestFile) then
      if Assigned(FBeforeOverwrite) then
        FBeforeOverwrite(Self, Result);
  end;
end;
procedure TVrCopyFile.DoProgress(BytesCopied: Integer;
  var Cancel: Boolean);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Self, BytesCopied, Cancel);
end;
procedure TVrCopyFile.Terminate;
begin
  FCancel := True;
end;
procedure TVrCopyFile.DoAfterCopy;
begin
  if Assigned(FAfterCopy) then FAfterCopy(Self);
end;
procedure TVrCopyFile.Execute;
var
  Source: TFileStream;
  Dest: TFileStream;
  Buffer: Pointer;
  BytesRead, ByteCount: Integer;
  CanCopy: Boolean;
  Filedate: Integer;
begin
  FCancel := false;
  ByteCount := 0;
  Buffer := nil;
  ReallocMem(Buffer, FBufferSize);
  try
    CheckExists;
    Source := TFileStream.Create(SourceFile, fmOpenRead);
    try
      FileDate := FileGetDate(Source.Handle);
      CanCopy := CheckOverwrite;
      if CanCopy then
      begin
        Dest := TFileStream.Create(DestFile, fmCreate);
        try
          repeat
            Application.ProcessMessages;
            BytesRead := Source.Read(Buffer^, BufferSize);
            if BytesRead > 0 then Dest.Write(Buffer^, BytesRead);
            Inc(ByteCount, BytesRead);
            DoProgress(ByteCount, FCancel);
          until (BytesRead <> FBufferSize) or (FCancel);
          if CopyDateTime then
            FileSetDate(Dest.Handle, FileDate);
        finally
          Dest.Free;
        end;
      end;
    finally
      Source.Free;
    end;
  finally
    ReallocMem(Buffer, 0);
    DoAfterCopy;
  end;
end;
function AddPathSlash(Path: string): string;
begin
  if (Path <> '') and (Path[Length(Path)] <> '') then
    Path := Path + '';
  Result := Path;
end;
{ TVrDirScan }
constructor TVrDirScan.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMask := '*.*';
  FPath := '';
  FRecursive := True;
end;
destructor TVrDirScan.Destroy;
begin
  FCancel := True;
  while FScanning do
    Application.ProcessMessages;
  inherited Destroy;
end;
procedure TVrDirScan.Cancel;
begin
  FCancel := True;
end;
function TVrDirScan.AbortScan: Boolean;
begin
  Result := (FCancel) or (Application.Terminated);
end;
procedure TVrDirScan.LocateFile(Path: string; SearchRec: TSearchRec);
begin
  if Assigned(FOnLocate) then
    FOnLocate(Self, Path, SearchRec, FCancel);
end;
procedure TVrDirScan.Notify;
begin
  if Assigned(FOnNotify) then
    FOnNotify(Self);
end;
procedure TVrDirScan.Scan(Path, Mask: string; Recurse: Boolean);
var
  NewPath: string;
  SRec: TSearchRec;
  ErrorCode: Integer;
begin
  if AbortScan then Abort;
  try
    ErrorCode := FindFirst(Path + Mask, faAnyFile, SRec);
    while ErrorCode = 0 do
    begin
      if (SRec.Attr and (faDirectory or faVolumeID)) = 0 then
        LocateFile(Path, SRec);
      if AbortScan then Abort;
      ErrorCode := FindNext(SRec);
    end;
  finally
    FindClose(SRec);
  end;
  if Recurse then
  begin
    try
      ErrorCode := FindFirst(Path + '*.*', faDirectory, SRec);
      while ErrorCode = 0 do
      begin
        Application.ProcessMessages;
        if (SRec.Attr and faDirectory) <> 0 then
          if (SRec.Name <> '.') and (SRec.Name <> '..') then
          begin
            NewPath := Path + SRec.Name + '';
            Scan(NewPath, Mask, Recurse);
          end;
        if AbortScan then Abort;
        ErrorCode := FindNext(SRec);
      end;
    finally
      FindClose(SRec);
    end;
  end;
  Application.ProcessMessages;
end;
procedure TVrDirScan.Execute;
var
  ScanPath, ScanMask: string;
begin
  FCancel := false;
  FScanning := True;
  try
    ScanPath := AddPathSlash(FPath);
    ScanMask := Trim(FMask);
    if ScanMask = '' then ScanMask := '*.*';
    Scan(ScanPath, ScanMask, FRecursive);
  finally
    FScanning := false;
  end;
  Notify;
end;
end.

						