vrsystem.pas

作工控的好控件

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.