program ShellD;
uses
SysUtils, Windows, ActiveX, ShlObj;
var
Malloc: IMalloc;
Desktop: IShellFolder;
pidlMyComputer: PItemIDList;
pidlResult: PItemIDList;
pidlInitialFolder: PItemIDList;
function BrowseCallbackProc( hWnd: HWND; uMsg: UINT; lParam: LPARAM;
lpData: LPARAM ): Integer; stdcall;
begin
Result := 0;
case uMsg of
BFFM_INITIALIZED:
begin
PostMessage( hWnd, BFFM_SETSELECTION, 0, Integer(pidlInitialFolder) );
PostMessage( hWnd, BFFM_SETSTATUSTEXT, 0,
Integer(PChar('Функция обратного вызова установлена.')) );
end;
end;
end;
function GetProgramFilesDirByKeyStr(KeyStr: string): string;
var
dwKeySize: DWORD;
Key: HKEY;
dwType: DWORD;
begin
if
RegOpenKeyEx( HKEY_LOCAL_MACHINE, PChar(KeyStr), 0, KEY_READ, Key ) = ERROR_SUCCESS
then
try
RegQueryValueEx( Key, 'ProgramFilesDir', nil, @dwType, nil, @dwKeySize );
if (dwType in [REG_SZ, REG_EXPAND_SZ]) and (dwKeySize > 0) then
begin
SetLength( Result, dwKeySize );
RegQueryValueEx( Key, 'ProgramFilesDir', nil, @dwType, PByte(PChar(Result)),
@dwKeySize );
end
else
begin
RegQueryValueEx( Key, 'ProgramFilesPath', nil, @dwType, nil, @dwKeySize );
if (dwType in [REG_SZ, REG_EXPAND_SZ]) and (dwKeySize > 0) then
begin
SetLength( Result, dwKeySize );
RegQueryValueEx( Key, 'ProgramFilesPath', nil, @dwType, PByte(PChar(Result)),
@dwKeySize );
end;
end;
finally
RegCloseKey( Key );
end;
end;
// Here is old way to retrieve Program Files folder location,
// Modern way is using of SHGetSpecialFolder (shfolder.dll) with
// CSIDL_PROGRAM_FILES constant.
function GetProgramFilesDir: string;
const
DefaultProgramFilesDir = '%SystemDrive%\Program Files';
var
FolderName: string;
dwStrSize: DWORD;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
FolderName :=
GetProgramFilesDirByKeyStr('Software\Microsoft\Windows NT\CurrentVersion');
end;
if Length(FolderName) = 0 then
begin
FolderName :=
GetProgramFilesDirByKeyStr('Software\Microsoft\Windows\CurrentVersion');
end;
if Length(FolderName) = 0 then FolderName := DefaultProgramFilesDir;
dwStrSize := ExpandEnvironmentStrings( PChar(FolderName), nil, 0 );
SetLength( Result, dwStrSize );
ExpandEnvironmentStrings( PChar(FolderName), PChar(Result), dwStrSize );
end;
var
bi: TBrowseInfo;
DisplayName: string;
ProgramFilesDir: WideString;
CharsDone: ULONG;
dwAttributes: DWORD;
Temp: string;
begin
ProgramFilesDir := GetProgramFilesDir;
if SUCCEEDED( SHGetMalloc( Malloc ) ) then
try
if SUCCEEDED( SHGetDesktopFolder( Desktop ) ) then
try
if SUCCEEDED( SHGetSpecialFolderLocation( 0, CSIDL_DRIVES, pidlMyComputer ) ) then
try
if
SUCCEEDED(
Desktop.ParseDisplayName( 0, nil, PWideChar(ProgramFilesDir), CharsDone,
pidlInitialFolder, dwAttributes )
)
then
try
SetLength( DisplayName, MAX_PATH );
FillChar( bi, sizeof(bi), 0 );
bi.pidlRoot := pidlMyComputer;
bi.pszDisplayName := PChar( DisplayName );
bi.lpszTitle := PChar('Выберите папку');
bi.ulFlags := BIF_STATUSTEXT;
bi.lpfn := BrowseCallbackProc;
pidlResult := SHBrowseForFolder( bi );
if Assigned(pidlResult) then
try
SetLength( Temp, MAX_PATH );
if SHGetPathFromIDList( pidlResult, PChar(Temp) ) then
begin
DisplayName := Temp;
end;
DisplayName := Trim(DisplayName) + '.';
MessageBox( 0, PChar(DisplayName), 'Вы успешно выбрали папку',
MB_OK or MB_ICONINFORMATION );
finally
Malloc.Free( pidlResult );
end;
finally
Malloc.Free( pidlInitialFolder );
end;
finally
Malloc.Free( pidlMyComputer );
end;
finally
Desktop := nil;
end;
finally
Malloc := nil;
end;
end. |