acshellctrls.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

  end;
  if FParent = nil then FParent := DesktopFolder;
  while AParent <> nil do begin
    AParent := AParent.Parent;
    if AParent <> nil then Inc(FLevel);
  end;
end;

destructor TacShellFolder.Destroy;
begin
  if Assigned(FDetails) then FreeAndNil(FDetails);
  if Assigned(FPIDL) then DisposePIDL(FPIDL);
  if Assigned(FFullPIDL) then DisposePIDL(FFullPIDL);
  inherited Destroy;
end;

function TacShellFolder.GetDetailInterface: IDetInterface;
begin
  if (not Assigned(FDetailInterface)) and Assigned(FIShellFolder) then begin
    FIShellDetails := GetIShellDetails(FIShellFolder, FFullPIDL, FViewHandle);
    if (not Assigned(FIShellDetails)) and (Win32MajorVersion >= 5) then begin
      FIShellFolder2 := GetIShellFolder2(FIShellFolder, FFullPIDL, FViewHandle);
      if not Assigned(FIShellFolder2) then // Hack!
       { Note: Although QueryInterface will not work in this instance,
         IShellFolder2 is indeed supported for this Folder if IShellDetails
         is not. In all tested cases, hard-casting the interface to
         IShellFolder2 has worked. Hopefully, Microsoft will fix this bug in
         a future release of ShellControls }
        FIShellFolder2 := IShellFolder2(FIShellFolder);
    end;
    if Assigned(FIShellFolder2) then Result := IDetInterface(FIShellFolder2) else Result := IDetInterface(FIShellDetails); // Casting is correct ?
    FDetailInterface := Result;
  end
  else Result := FDetailInterface;
end;

function TacShellFolder.GetShellDetails: IShellDetails;
begin
  if not Assigned(FDetailInterface) then GetDetailInterface;
  Result := FIShellDetails;
end;

function TacShellFolder.GeTacShellFolder2: IShellFolder2;
begin
  if not Assigned(FDetailInterface) then GetDetailInterface;
  Result := FIShellFolder2;
end;

procedure TacShellFolder.LoadColumnDetails(RootFolder: TacShellFolder; Handle: THandle; ColumnCount: integer);
  procedure GetDetailsOf(AFolder: TacShellFolder; var Details: TWin32FindData);
  var
    szPath: array[ 0 .. MAX_PATH] of char;
    Path: string;
    Handle: THandle;
  begin
    FillChar(Details, SizeOf(Details), 0);
    FillChar(szPath,MAX_PATH,0);
    Path := AFolder.PathName;
    Handle := Windows.FindFirstFile(PChar(Path), Details);
    try
      if Handle = INVALID_HANDLE_VALUE then NoFolderDetails(AFolder, Windows.GetLastError, seSystem);
    finally
      Windows.FindClose(Handle);
    end;
  end;
  function CalcFileSize(FindData: TWin32FindData): int64;
  begin
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0
      then Result := FindData.nFileSizeHigh * MAXDWORD + FindData.nFileSizeLow
      else Result := -1;
  end;
  function CalcModifiedDate(FindData: TWin32FindData): TDateTime;
  var
    LocalFileTime: TFileTime;
    Age : integer;
  begin
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then begin
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      if FileTimeToDosDateTime(LocalFileTime, LongRec(Age).Hi, LongRec(Age).Lo) then begin
        Result := FileDateToDateTime(Age);
        Exit;
      end;
    end;
    Result := -1;
  end;
  function DefaultDetailColumn(FindData: TWin32FindData; Col: integer): string;
  begin
    case Col of
      //1 : Result := FindData.cFileName; // Name
      1 : Result := IntToStr(CalcFileSize(FindData)); // Size
      2 : Result := ExtractFileExt(FindData.cFileName); // Type
      3 : Result := DateTimeToStr(CalcModifiedDate(FindData)); // Modified
      4 : Result := IntToStr(FindData.dwFileAttributes);
    end;
  end;
  procedure AddDetail(HR: HResult; PIDL: PItemIDList; SD: TShellDetails);
  begin
    if HR = S_OK then FDetails.Add(StrRetToString(PIDL, SD.str)) else FDetails.Add('');
  end;
var
  SF2: IShellFolder2;
  ISD: IShellDetails;
  SD: TShellDetails;
  J: Integer;
  HR: HResult;
  FindData: TWin32FindData;
begin
  if not Assigned(FDetails) or (FDetails.Count >= ColumnCount) then Exit; // Details are loaded
  FDetails.Clear;
  FViewHandle := Handle;
  SF2 := RootFolder.ShellFolder2;
  if Assigned(SF2) then begin
    // Already have name and icon, so see if we can provide details
    for J := 1 to ColumnCount do begin
      HR := SF2.GetDetailsOf(FPIDL, J, SD);
      AddDetail(HR, FPIDL, SD);
    end;
  end
  else begin
    ISD := RootFolder.ShellDetails;
    if Assigned(ISD) then begin
      for J := 1 to ColumnCount do begin
        HR := ISD.GetDetailsOf(FPIDL, J, SD);
        AddDetail(HR, FPIDL, SD);
      end;
    end
    else if (fpFileSystem in RootFolder.Properties) then begin
      GetDetailsOf(Self, FindData);
      for J := 1 to ColumnCount do FDetails.Add(DefaultDetailColumn(FindData, J));
    end;
  end;
end;

function TacShellFolder.GetDetails(Index: integer): string;
begin
  if FDetails.Count > 0 then
    Result := FDetails[Index-1] // Index is 1-based
  else
    Raise Exception.CreateFmt('%s: Missing call to LoadColumnDetails', [ Self.DisplayName(seSystem) ] );
end;

procedure TacShellFolder.SetDetails(Index: integer; const Value: string);
begin
  if Index < FDetails.Count
    then FDetails[Index - 1] := Value // Index is 1-based
    else FDetails.Insert(Index - 1, Value); // Index is 1-based
end;

function TacShellFolder.ParenTacShellFolder: IShellFolder;
begin
  if FParent <> nil then Result := FParent.ShellFolder else OLECheck(SHGetDesktopFolder(Result));
end;

function TacShellFolder.Properties: TacShellFolderProperties;
begin
  Result := GetProperties(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.Capabilities: TacShellFolderCapabilities;
begin
  Result := GetCaps(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.SubFolders: Boolean;
begin
  Result := GetHasSubFolders(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.IsFolder(const Name : string = ''; OpenZipFiles : Boolean = True): Boolean;
begin
  if not OpenZipFiles and (Name <> '') and (LowerCase(ExtractFileExt(Name)) = '.zip') // Thnx for Lexa v4.60
    then Result := False
    else Result := GetIsFolder(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.PathName: string;
begin
  Result := GetDisplayName(DesktopShellFolder, FFullPIDL, SHGDN_FORPARSING, seSystem);
end;

function TacShellFolder.DisplayName(ShowExt: TacShowExtension): string;
var
  ParentFolder: IShellFolder;
begin
  if Parent <> nil then ParentFolder := ParenTacShellFolder else ParentFolder := DesktopShellFolder;
  Result := GetDisplayName(ParentFolder, FPIDL, SHGDN_INFOLDER, ShowExt);
end;

function TacShellFolder.Rename(const NewName: Widestring): boolean;
var
  NewPIDL: PItemIDList;
begin
  Result := False;
  if not (fcCanRename in Capabilities) then Exit;

  Result := ParenTacShellFolder.SetNameOf(0, FPIDL, PWideChar(NewName), SHGDN_NORMAL, NewPIDL) = S_OK;
  if Result then begin
    DisposePIDL(FPIDL);
    DisposePIDL(FFullPIDL);
    FPIDL := NewPIDL;
    if (FParent <> nil) then FFullPIDL := ConcatPIDLs(FParent.FPIDL, NewPIDL) else FFullPIDL := CopyPIDL(NewPIDL);
  end
  else Raise Exception.Create(Format('Rename to %s failed',[NewName]));
end;

function TacShellFolder.ImageIndex(LargeIcon: Boolean): Integer;
begin
  Result := GetShellImage(AbsoluteID, LargeIcon, False);
end;

function TacShellFolder.ExecuteDefault: Integer;
var
  SEI: TShellExecuteInfo;
begin
  FillChar(SEI, SizeOf(SEI), 0);
  with SEI do begin
    cbSize := SizeOf(SEI);
    wnd := Application.Handle;
    fMask := SEE_MASK_INVOKEIDLIST;
    lpIDList := AbsoluteID;
    nShow := SW_SHOW;
  end;
  Result := Integer(ShellExecuteEx(@SEI));
end;

function TacShellFolder.IsFile(const Name : string = ''; OpenZipFiles : Boolean = True): Boolean;
begin
  if not OpenZipFiles and (Name <> '') and (LowerCase(ExtractFileExt(Name)) = '.zip') // Thnx for Lexa v4.60
    then Result := True
    else Result := GetIsFile(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.IsFileFolder: Boolean;
begin
  Result := GetIsFileFolder(ParenTacShellFolder, FPIDL);
end;

function TacShellFolder.IsReadOnly: Boolean;
begin
  Result := GetIsReadOnly(ParenTacShellFolder, FPIDL);
end;

{ TacCustomShellChangeNotifier }

procedure TacCustomShellChangeNotifier.Change;
  function NotifyOptionFlags: DWORD;
  begin
    Result := 0;
    if nfFileNameChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_FILE_NAME;
    if nfDirNameChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_DIR_NAME;
    if nfSizeChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_SIZE;
    if nfAttributeChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_ATTRIBUTES;
    if nfWriteChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_LAST_WRITE;
    if nfSecurityChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_SECURITY;
  end;
begin
  if Assigned(FThread) then begin
    FThread.SetDirectoryOptions(Root, LongBool(FWatchSubTree), NotifyOptionFlags);
  end;
end;

constructor TacCustomShellChangeNotifier.Create(AOwner : TComponent);
begin
  inherited;
  FRoot := 'C:\';      { Do not localize }
  FWatchSubTree := True;
  FFilters := [nfFilenameChange, nfDirNameChange];
  Start;
end;

destructor TacCustomShellChangeNotifier.Destroy;
var
  Temp : TacShellChangeThread;
begin
  if Assigned(FThread) then begin
    OnChange := nil;
    Temp := FThread;
    FThread := nil;
    Temp.Terminate;
    ReleaseMutex(Temp.FMutex);
  end;
  inherited;
end;

procedure TacCustomShellChangeNotifier.SetRoot(const Value: TacRoot);
begin
  if not SameText(FRoot, Value) then begin
    FRoot := Value;
    Change;
  end;
end;

procedure TacCustomShellChangeNotifier.SetFilters(const Value: TacNotifyFilters);
begin
  FFilters := Value;
  Change;
end;

procedure TacCustomShellChangeNotifier.SetOnChange(const Value: TThreadMethod);
begin
  FOnChange := Value;
  if Assigned(FThread) then FThread.ChangeEvent := FOnChange else Start;
end;

procedure TacCustomShellChangeNotifier.SetWatchSubTree(const Value: Boolean);
begin
  FWatchSubTree := Value;
  Change;
end;

procedure TacCustomShellChangeNotifier.Start;
  function NotifyOptionFlags: DWORD;
  begin
    Result := 0;
    if nfFileNameChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_FILE_NAME;
    if nfDirNameChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_DIR_NAME;
    if nfSizeChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_SIZE;
    if nfAttributeChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_ATTRIBUTES;
    if nfWriteChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_LAST_WRITE;
    if nfSecurityChange in FFilters then Result := Result or FILE_NOTIFY_CHANGE_SECURITY;
  end;
begin
  if Assigned(FOnChange) then begin
    FThread := TacShellChangeThread.Create(FOnChange);
    FThread.SetDirectoryOptions(FRoot, LongBool(FWatchSubTree), NotifyOptionFlags);
    FThread.Resume;
  end;
end;

{ TacShellChangeThread }

constructor TacShellChangeThread.Create(ChangeEvent: TThreadMethod);
begin
  FreeOnTerminate := True;
  FChangeEvent := ChangeEvent;
  FMutex := CreateMutex(nil, True, nil);
  //Mutex is used to wake up the thread as it waits for any change notifications.
  WaitForSingleObject(FMutex, INFINITE); //Grab the mutex.
  FWaitChanged := false;
  inherited Create(True);
end;

destructor TacShellChangeThread.Destroy;
begin
  if FWaitHandle <> ERROR_INVALID_HANDLE then FindCloseChangeNotification(FWaitHandle);
  CloseHandle(FMutex);
  inherited Destroy;
end;

procedure TacShellChangeThread.Execute;
var
  Obj: DWORD;
  Handles: array[0..1] of DWORD;
begin
  EnterCriticalSection(CS);
  FWaitHandle := FindFirstChangeNotification(PChar(FDirectory), LongBool(FWatchSubTree), FNotifyOptionFlags);
  LeaveCriticalSection(CS);
  if FWaitHandle = ERROR_INVALID_HANDLE then Exit;
  while not Terminated do begin
    Handles[0] := FWaitHandle;
    Handles[1] := FMutex;
    Obj := WaitForMultipleObjects(2, @Handles, False, 1000);//INFINITE); // v5.04
    case Obj of
      WAIT_OBJECT_0 : begin
        Synchronize(FChangeEvent);
        FindNextChangeNotification(FWaitHandle);
      end;
      WAIT_OBJECT_0 + 1 : ReleaseMutex(FMutex);
      WAIT_FAILED : Exit;
    end;
    EnterCriticalSection(CS);
    if FWaitChanged then begin
      FWaitHandle := FindFirstChangeNotification(PChar(FDirectory), LongBool(FWatchSubTree), FNotifyOptionFlags);
      FWaitChanged := false;
    end;
    LeaveCriticalSection(CS);
  end;
end;

procedure TacShellChangeThread.SetDirectoryOptions(const Directory: String; WatchSubTree: Boolean; NotifyOptionFlags: DWORD);
begin
  EnterCriticalSection(CS);
  FDirectory := Directory;
  FWatchSubTree := WatchSubTree;
  FNotifyOptionFlags := NotifyOptionFlags;

  // Release the current notification handle
  FindCloseChangeNotification(FWaitHandle);
  FWaitChanged := true;
  LeaveCriticalSection(CS);