一个很有用的单元

unit ShlFunc;

{ 本单元可使用尽可能少的资源完成下面的功能, }
interface

const
    // 用于描述系统文件夹的前缀常量
    nvF_PgmMenu = #$82; // [开始][程序]
    nvF_MyDoc = #$85; // 我的文档
    nvF_BookMrk = #$86; // 收藏夹
    nvF_Startup = #$87; // [开始][启动]
    nvF_Recent = #$88; // [开始][文档]
    nvF_SendTo = #$89; // 发送到...
    nvF_StrMenu = #$8B; // [开始]
    nvF_Desktop = #$90; // 桌面
    nvF_AppData = #$9A; // Application Data
    nvF_Windows = #$A0; // Windows
    nvF_System = #$A1; // Windows\System
    nvF_PgmFile = #$A2; // Program Files
    nvF_Temp = #$A3; // Temp Directory
    {
      ===============================================================================
    }
    // 取系统文件夹, nvFolder 为上述常数, 可返回短文件名
function GetSysFolder(nvFolder: Char; ShortPath: Boolean): String;
function DoGetSysFolder(nvFolder: Char; ShortPath: Boolean; var S: String): Integer;
// 展开如 nvF_Desktop+'MyFolder\MySubFolder' 的路径名, 结果用 ExpandedPathName 变量访问
procedure DoExpandPathName(const xPath: String);
// 搜索文件夹, 可返回短文件名, hWnd可以是0(nil)或调用窗口的Handle
function SearchPaths(hWND: Integer; const Title: String; ShortPath: Boolean): String;
// 创建快捷方式(ShortCutName可描述为 nvF_xxx+'...\...\YYY" )
// 如果ShortCutName='' 那么加入到[开始][文档]
function CreateFileShortCut(const FileName, ShortCutName: String): Boolean;
// 通用字符串函数(从Src中的第SrcId个开始拷贝Count个字符到Tar的TarId开始的位置, 返回目标串的长度)
// 该函数可避免频繁的字符串内存重分配
// SrcId, TarId, Count都可以为0, TarId=0 时将在Tar后面连接Src, Count=0 时将一直复制到Src的结尾
function StrReplace(const Src: String; var Tar: String; SrcId, TarId, Count: Integer): Integer;
// 取文件的短文件名(sLen为FileName的当前长度, 如果为0则自动匹配; 返回目标串的长度)
function FileName8_3(var FileName: String; const sLen: Integer): Integer;
// 路径是否存在, 如果ForceCreate, 那么如果路径不存在则自动创建)
function PathExists(const xPath: String; ForceCreate: Boolean): Boolean;

var
    ExpandedPathName: string;

implementation

uses
    ShlObj, Windows;

var
    pxBrowse: PBrowseInfoA;
    pxItemID: PItemIDList;
    BrowseDlgTitle: String;

    {
      ===============================================================================
    }
function StrReplace(const Src: String; var Tar: String; SrcId, TarId, Count: Integer): Integer;
begin
    if SrcId <= 0 then
        SrcId := 0
    else
        Dec(SrcId);
    if Count <= 0 then
        Count := Length(Src) - SrcId;
    if TarId <= 0 then
    begin
        TarId := Length(Tar);
        SetLength(Tar, TarId + Count);
    end
    else
        Dec(TarId);
    for Result := 1 to Count do
        Tar[TarId + Result] := Src[SrcId + Result];
    Result := TarId + Count;
end;

{
  ===============================================================================
}
function FileName8_3(var FileName: String; const sLen: Integer): Integer;
var
    I, X: Integer;
begin
    try
        if sLen > 0 then
        begin
            X := Length(FileName) - sLen;
            if X < 128 then
                SetLength(FileName, sLen + 128);
            X := sLen + 1;
        end
        else
        begin
            X := Length(FileName) + 1;
            SetLength(FileName, X + 255);
        end;
        FileName[X] := #0;
        Result := GetShortPathName(@FileName[1], @FileName[X + 1], 255);
        for I := 1 to Result do
            FileName[I] := FileName[X + I];
        if sLen > 0 then
            FileName[Result + 1] := #0
        else
            SetLength(FileName, Result);
    except
        Result := 0;
    end;
end;

{
  ===============================================================================
}
procedure DoExpandPathName(const xPath: String);
var
    X: Integer;
begin
    if Ord(xPath[1]) < $80 then
        ExpandedPathName := xPath + #0
    else
    begin
        if Length(ExpandedPathName) < 255 then
            SetLength(ExpandedPathName, 255);
        X := DoGetSysFolder(xPath[1], false, ExpandedPathName);
        X := StrReplace(xPath, ExpandedPathName, 2, X + 1, 0);
        ExpandedPathName[X + 1] := #0;
    end;
end;

function PathExists(const xPath: String; ForceCreate: Boolean): Boolean;
var
    X: Integer;
    procedure CreatePaths;
    var
        N: Integer;
        ch: Char;
    begin
        for N := 1 to Length(ExpandedPathName) do
        begin
            ch := ExpandedPathName[N];
            if ch = #0 then
                Break;
            if ch <> '\' then
                Continue;
            ch := ExpandedPathName[N + 1];
            ExpandedPathName[N + 1] := #0;
            X := GetFileAttributes(@ExpandedPathName[1]);
            ExpandedPathName[N + 1] := ch;
            if (X <> -1) and (FILE_ATTRIBUTE_DIRECTORY and X <> 0) then
                Continue;
            ExpandedPathName[N] := #0;
            CreateDirectory(@ExpandedPathName[1], nil);
            ExpandedPathName[N] := '\';
        end;
    end;

begin
    DoExpandPathName(xPath);
    X := GetFileAttributes(@ExpandedPathName[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;

{
  ===============================================================================
}
function GetSysFolder(nvFolder: Char; ShortPath: Boolean): String;
begin
    SetLength(Result, 255);
    SetLength(Result, DoGetSysFolder(nvFolder, ShortPath, Result));
end;

function DoGetSysFolder(nvFolder: Char; ShortPath: Boolean; var S: String): Integer;
var
    X: Integer;
begin
    Result := 0;
    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, @S[1]) then
                Exit;
            X := Pos(#0, S) - 1;
        end
        else
            case nvFolder of
                nvF_Windows:
                    X := GetWindowsDirectory(@S[1], 255);
                nvF_System:
                    X := GetSystemDirectory(@S[1], 255);
                nvF_PgmFile:
                    Exit;
                nvF_Temp:
                    X := GetTempPath(255, @S[1]);
            else
                Exit;
            end; { case }
        if ShortPath then
            X := FileName8_3(S, X);
        if S[X] <> '\' then
        begin
            Inc(X);
            S[X] := '\';
        end;
        Result := X;
        S[X + 1] := #0;
    except
        Exit;
    end;
end;

{
  ===============================================================================
}
function CreateFileShortCut(const FileName, ShortCutName: String): Boolean;
var
    S: 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);
            DoExpandPathName(ShortCutName);
            if not PathExists(ExpandedPathName, True) then
                Exit;
            X := StrReplace('.lnk'#0, ExpandedPathName, 0, Pos(#0, ExpandedPathName), 0);
            Result := CopyFile(@S[1], @ExpandedPathName[1], false);
            if Result then
                DeleteFile(@S[1]);
        end;
    except
    end;
end;

{
  ===============================================================================
}
procedure InitBrowseInfo(hWND: Integer);
begin
    if pxBrowse = nil then
        New(pxBrowse);
    with pxBrowse^ do
    begin
        hWndOwner := hWND;
        pidlRoot := nil;
        pszDisplayName := nil;
        lpszTitle := PChar(BrowseDlgTitle);
        ulFlags := BIF_RETURNONLYFSDIRS;
        lpfn := nil;
    end;
end;

{
  ===============================================================================
}
function SearchPaths(hWND: Integer; const Title: String; ShortPath: Boolean): String;
begin
    SetLength(Result, 0);
    try;
        if Length(Title) <> 0 then
            BrowseDlgTitle := Title;
        InitBrowseInfo(hWND);
        pxItemID := SHBrowseForFolder(pxBrowse^);
        Dispose(pxBrowse);
        pxBrowse := nil;
        if pxItemID = nil then
            Exit;
        SetLength(Result, 255);
        SHGetPathFromIDList(pxItemID, @Result[1]);
        hWND := Pos(#0, Result);
        if ShortPath then
            hWND := FileName8_3(Result, hWND);
        if Result[hWND] <> '\' then
        begin
            Inc(hWND);
            Result[hWND] := '\';
        end;
        SetLength(Result, hWND);
    except
        SetLength(Result, 0);
    end;
end;

{
  ===============================================================================
}
initialization

BrowseDlgTitle := '搜索文件夹';
pxBrowse := nil;

finalization

if pxBrowse <> nil then
    Dispose(pxBrowse);

end.