Tips (1541)

Tip Bewertung (701):

uses
  ActiveX, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
// Replace CSIDL_HISTORY with the constants below
var
  Allocator: IMalloc;
  SpecialDir: PItemIdList;
  FBuf: array[0..MAX_PATH] of Char;
  PerDir: string;
begin
  if SHGetMalloc(Allocator) = NOERROR then
  begin
    SHGetSpecialFolderLocation(Form1.Handle, CSIDL_HISTORY, SpecialDir);
    SHGetPathFromIDList(SpecialDir, @FBuf[0]);
    Allocator.Free(SpecialDir);
    ShowMessage(string(FBuf));
  end;
end;

// With Windows Me/2000, the SHGetSpecialFolderLocation function
// is superseded by ShGetFolderLocation.


// function to get the desktop folder location:

function GetDeskTopPath : string;
var
  shellMalloc: IMalloc;
  ppidl: PItemIdList;
  PerDir: string;
begin
  ppidl := nil;
  try
    if SHGetMalloc(shellMalloc) = NOERROR then
    begin
      SHGetSpecialFolderLocation(Form1.Handle, CSIDL_DESKTOP, ppidl);
      SetLength(Result, MAX_PATH);
      if not SHGetPathFromIDList(ppidl, PChar(Result)) then
        raise exception.create('SHGetPathFromIDList failed : invalid pidl');
      SetLength(Result, lStrLen(PChar(Result)));
    end;
  finally
   if ppidl <> nil then
         shellMalloc.free(ppidl);
  end;
end;

{
  Constants:

  CSIDL_DESKTOP
  CSIDL_INTERNET
  CSIDL_PROGRAMS
  CSIDL_CONTROLS
  CSIDL_PRINTERS
  CSIDL_PERSONAL
  CSIDL_FAVORITES
  CSIDL_STARTUP
  CSIDL_RECENT
  CSIDL_SENDTO
  CSIDL_BITBUCKET
  CSIDL_STARTMENU
  CSIDL_DESKTOPDIRECTORY
  CSIDL_DRIVES
  CSIDL_NETWORK
  CSIDL_NETHOOD
  CSIDL_FONTS
  CSIDL_TEMPLATES
  CSIDL_COMMON_STARTMENU
  CSIDL_COMMON_PROGRAMS
  CSIDL_COMMON_STARTUP
  CSIDL_COMMON_DESKTOPDIRECTORY
  CSIDL_APPDATA
  CSIDL_PRINTHOOD
  CSIDL_ALTSTARTUP
  CSIDL_COMMON_ALTSTARTUP
  CSIDL_COMMON_FAVORITES
  CSIDL_INTERNET_CACHE
  CSIDL_COOKIES
  CSIDL_HISTORY
}


{***********************************************************}
{ Read paths from registry. by LENIN INC }

uses
  Windows, SysUtils, Registry;

type
  TSystemPath = (Desktop, StartMenu,
    Programs, Startup, Personal, AppData,
    Fonts, SendTo, Recent, Favorites, Cache,
    Cookies, History, NetHood, PrintHood,
    Templates, LocADat, WindRoot, WindSys,
    TempPath, RootDir, ProgFiles, ComFiles,
    ConfigPath, DevicePath, MediaPath, WallPaper);

function GetSystemPath(SystemPath: TSystemPath): string;
var
  ph: PChar;
begin
  with TRegistry.Create do
    try
      RootKey := HKEY_CURRENT_USER;
      OpenKey('\Software\Microsoft\Windows\CurrentVersion\' +
        'Explorer\Shell Folders', True);
      case SystemPath of
        Desktop: Result   := ReadString('Desktop');
        StartMenu: Result := ReadString('Start Menu');
        Programs: Result  := ReadString('Programs');
        Startup: Result   := ReadString('Startup');
        Personal: Result  := ReadString('Personal');
        AppData: Result   := ReadString('AppData');
        Fonts: Result     := ReadString('Fonts');
        SendTo: Result    := ReadString('SendTo');
        Recent: Result    := ReadString('Recent');
        Favorites: Result := ReadString('Favorites');
        Cache: Result     := ReadString('Cache');
        Cookies: Result   := ReadString('Cookies');
        History: Result   := ReadString('History');
        NetHood: Result   := ReadString('NetHood');
        PrintHood: Result := ReadString('PrintHood');
        Templates: Result := ReadString('Templates');
        LocADat: Result   := ReadString('Local AppData');
        WindRoot: 
          begin
            GetMem(ph, 255);
            GetWindowsDirectory(ph, 254);
            Result := Strpas(ph);
            Freemem(ph);
          end;
        WindSys: 
          begin
            GetMem(ph, 255);
            GetSystemDirectory(ph, 254);
            Result := Strpas(ph);
            Freemem(ph);
          end;
        TempPath: 
          begin
            GetMem(ph, 255);
            GetTempPath(254, ph);
            Result := Strpas(ph);
            Freemem(ph);
          end;
        RootDir: 
          begin
            GetMem(ph, 255);
            GetSystemDirectory(ph, 254);
            Result := (Copy(Strpas(ph), 1, 2));
            Freemem(ph);
          end;
      end;
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion', True);
      case SystemPath of
        ProgFiles: Result := ReadString('ProgramFilesDir');
        ComFiles: Result := ReadString('CommonFilesDir');
        ConfigPath: Result := ReadString('ConfigPath');
        DevicePath: Result := ReadString('DevicePath');
        MediaPath: Result := ReadString('MediaPath');
        WallPaper: Result := ReadString('WallPaperDir');
      end;
    finally
      CloseKey;
      Free;
    end;
  if (Result <> '') and (Result[Length(Result)] <> '\') then
    Result := Result + '\';
end;

//Use
procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetSystemPath(DevicePath);
end;