一个很有用的单元

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
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' 的路径名, 结果用 ExpandedPathName 变量访问
procedure DoExpandPathName(const xPath: String);
//搜索文件夹, 可返回短文件名, hWnd可以是0(nil)或调用窗口的Handle
function SearchPaths(hWND: Integer; const Title: String; ShortPath: Boolean): String;
//创建快捷方式(ShortCutName可描述为 nvF_xxx+'......" )
//如果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:= 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.