shlfile.pas

超级Delphi函数包,包括编程时常需要的一些函数

  FillChar(SFI, SizeOf(SFI), 0);

  if FileExists(Path) or DirectoryExists(Path) then

    SHGetFileInfo(PChar(Path), 0, SFI, SizeOf(TSHFileInfo),

      SHGFI_SYSICONINDEX)

  else

    SHGetFileInfo(PChar(Path), Attrs, SFI, SizeOf(TSHFileInfo),

      SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);

  Result := SFI.iIcon;

end;

function GetAssociatedIcon(const Extension: string; SmallIcon: Boolean): HIcon;

var

  Info              : TSHFileInfo;

  Flags             : Cardinal;

begin

  if SmallIcon then

    Flags := SHGFI_ICON or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES

  else

    Flags := SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES;

  SHGetFileInfo(PChar(Extension), FILE_ATTRIBUTE_NORMAL, Info,

    SizeOf(TSHFileInfo), Flags);

  Result := Info.hIcon;

end;

function ExtractFileName(const Filename: string;

  Extension : boolean = true): string;

var

  i : integer;

begin

  Result := SysUtils.ExtractFileName(Filename);

  if not Extension then

  begin

    for I := Length(Result) downto 1 do

      If Result[I]='.' then Break;

    if I > 1 then

      Delete(Result, I, MaxInt);

  end;

end;

function GetSystemFolder(nvFolder: Char; ShortPath: Boolean): string;

var

  X: Integer;

begin

  SetLength(Result, MAX_PATH);

  Try

    X:= Ord(nvFolder);

    if X < $A0 then

    begin

      if SHGetSpecialFolderLocation(0, (X and $7F), pxItemID) <> NOERROR then

        exit;

      if pxItemID = nil then

        exit;

      if not SHGetPathFromIDList(pxItemID, PChar(Result)) then

        exit;

      X:= Pos(#0, Result) - 1;

    end

    else case nvFolder of

      nvF_Windows : X:= GetWindowsDirectory(PChar(Result), MAX_PATH);

      nvF_System : X:= GetSystemDirectory(PChar(Result), MAX_PATH);

      nvF_PgmFile : Exit;

      nvF_Temp : X:= GetTempPath(MAX_PATH, PChar(Result));

      else exit;

    end; (*case*)

    SetLength(Result, X);

    if ShortPath then Result:= GetShortName(Result);

    if Result[Length(Result)] <> '\' then

      Result := Result + '\';

  except

    SetLength(Result, 0);

  end;

end;

function ExpandPathName(Path: string) : string;

var

  X: Integer;

begin

  if Path[1] in [nvF_Temp, nvF_PgmMenu, nvf_Printer, nvF_MyDoc,

    nvF_BookMrk, nvF_Startup, nvF_Recent, nvF_SendTo, nvf_Recycle,

    nvF_PgmFile, nvF_System, nvF_Windows, nvF_AppData, nvF_NETWORK,

    nvF_Drives, nvF_Desktop, nvF_StrMenu] then

  begin

    result := GetSystemFolder(Path[1], False);

    Delete(Path, 1, 1);

    Insert(Result, Path, 1);

  end;

end;

function CreateFileShortCut(const FileName, ShortCutName: String): Boolean;

var

  S, V : string;

  X, Y: Integer;

begin

  Result:= False;

  try

    SHAddToRecentDocs(SHARD_PATH, PChar(FileName));

    if Length(ShortCutName) <> 0 then

    begin

      Y:= 0;

      for X:= Length(FileName) downto 1 do

        if FileName[X] = '\' then

        begin

          Y:= X;

          Break;

        end;

      SetLength(S, 255);

      SHGetSpecialFolderLocation(0, CSIDL_RECENT, pxItemID);

      SHGetPathFromIDList(pxItemID, @S[1]);

      X:= Pos(#0, S);

      if S[X-1] <> '\' then

      begin

        S[X]:= '\';

        Inc(X);

      end;

      X:= StrReplace(FileName, S, Y+1, X, 0);

      X:= StrReplace('.lnk'#0, S, 0, X+1, 0);

      V := ExpandPathName(ShortCutName);

      if not PathExists(V, True) then

        Exit;

      X:= StrReplace('.lnk'#0, V, 0, Pos(#0, V), 0);

      Result:= CopyFile(@S[1], @V[1], False);

      if Result then

        DeleteFile(S);

    end;

  except

  end;

end;

function GetShortcutTarget(const ShortCutFileName: string):string;

var

  Psl:IShellLink;

  Ppf:IPersistFile;

  WideName: array [0..MAX_PATH] of WideChar;

  pResult: array [0..MAX_PATH-1] Of Char;

  Data:TWin32FindData;

const

  IID_IPersistFile: TGUID = (

  D1:$0000010B; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

begin

  CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER, IID_IShellLinkA ,psl);

  psl.QueryInterface(IID_IPersistFile,ppf);

  MultiByteToWideChar(CP_ACP, 0, pChar(ShortcutFilename), -1, WideName, Max_Path);

  ppf.Load(WideName,STGM_READ);

  psl.Resolve(0,SLR_ANY_MATCH);

  psl.GetPath( @pResult,MAX_PATH,Data,SLGP_UNCPRIORITY);

  Result:=StrPas(@pResult);

end;

function BrowseFolderDialog(HWND: Integer; const Title: string;

  ShortPath: Boolean): string;

var

  s : string;

begin

  try

    if Length(Title) <> 0 then BrowseDlgTitle:= Title;

    InitBrowseInfo(hWND);

    pxItemID:= SHBrowseForFolder(pxBrowse^);

    Dispose(pxBrowse);

    pxBrowse:= nil;

    if pxItemID = nil then Exit;

    SetLength(s, 255);

    SHGetPathFromIDList(pxItemID, @s[1]);

    if ShortPath then Result:= GetShortName(s);

    if Result[Length(Result)] <> '\' then

       Result := Result + '\';

  except

    Result := '';

  end;

end;


procedure OpenSpecialFolder(FolderID: integer; Handle: HWND = 0);

  procedure FreePidl(pidl: PItemIDList);

  var

    allocator : IMalloc;

  begin

    if Succeeded(shlobj.SHGetMalloc(allocator)) then

    begin

      allocator.Free(pidl);

      {$IFDEF VER90}

      allocator.Release;

      {$ENDIF}

    end;

  end;

var

  exInfo : TShellExecuteInfo;

begin

  // initialize all fields to 0

  FillChar(exInfo, SizeOf(exInfo), 0);

  with exInfo do

  begin

    cbSize := SizeOf(exInfo); // required!

    fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;

    Wnd := Handle;

    nShow := SW_SHOWNORMAL;

    lpVerb := 'open';

    ShGetSpecialFolderLocation(Handle, FolderID, PItemIDLIst(lpIDList));

  end;

  ShellExecuteEx(@exInfo);

  FreePIDL(exinfo.lpIDList);

end;

function ShowFileProperties(FileName: string; Handle: HWND):Boolean;

var

  FileInfo: TSHELLEXECUTEINFO;

begin

  with FileInfo do

  begin

    cbSize := SizeOf(FileInfo);

    lpFile := PAnsiChar(FileName);

    Wnd := Handle;

    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or SEE_MASK_FLAG_NO_UI;

    lpVerb := PAnsiChar('properties');

    lpIDList := nil;

    lpDirectory := nil;

    nShow := 0;

    hInstApp := 0;

    lpParameters := nil;

    dwHotKey := 0;

    hIcon := 0;

    hkeyClass := 0;

    hProcess := 0;

    lpClass := nil;

  end;

  Result := ShellExecuteEX(@FileInfo);

end;

function PathExists(const xPath: String; ForceCreate: Boolean): Boolean;

var

   X : Integer;

   S : string;

   procedure CreatePaths;

   var

      N: Integer; ch: Char;

   begin

      for N:= 1 to Length(S) do

      begin

         ch:= S[N];

         if ch = #0 then Break;

         if ch <> '\' then Continue;

         ch:= S[N+1];

         S[N+1]:= #0;

         X:= GetFileAttributes(@S[1]);

         S[N+1]:= ch;

         if (X <> -1) and (FILE_ATTRIBUTE_DIRECTORY and X <> 0) then Continue;

         S[N]:= #0;

         CreateDirectory(@S[1], nil);

         S[N]:= '\';

      end;

   end;


begin

   S := ExpandPathName(xPath);

   X:= GetFileAttributes(@S[1]);

   Result:= (X <> -1) and (FILE_ATTRIBUTE_DIRECTORY and X <> 0);

   if Result or (not ForceCreate) then Exit;

   try

      CreatePaths;

      Result:= True;

   except

   end;

end;

initialization

   BrowseDlgTitle:= ' 搜索文件夹 ';

   pxBrowse:= nil;

finalization

   if pxBrowse <> nil then Dispose(pxBrowse);


end.