xfiles.pas

我自己用的Delphi函数单元 具体说明见打包文件的HELP目录下面

  if (I1 = 0) or (I2 = 0) then Exit;

  Result := Copy(Path, I2 + I1 + 1, Length(Path));
end;

//------------------------------------------------------------------//
//取得父目录，若是最高层，返回目录本身，支持UNC命名，如
//c:\windows\system  -> c:\windows
//\\zebra\c\windows\ -> \\zebra\c\
//\\zebra\c\         -> \\zebra\c\
//c:\                -> c:\
function DirParent(Path: string): string;
var
  iLastAntiSlash: Integer;

  function CountAntiSlash: Integer;
  var
    I: Integer;
  begin
    Result := 0;
    I := 1;
    repeat
      if IsDBCSLeadByte(Ord(Path[I])) then
        Inc(I, 2)
      else
      begin
        if Path[I] = '\' then
        begin
          iLastAntiSlash := I;
          Inc(Result);
        end;
        Inc(I);
      end;
    until I > Length(Path);
  end;

begin
  // 'c:\windows\system\' => 'c:\window\'
  // 'f:\' => 'f:\'
  // '\\xshadow\f\fonts' => '\\xshadow\f\'
  // '\\xshadow\f\' => '\\xshadow\f\'
  Path := DelSlash(Path);

  if Length(Path) > 3 then
  begin
    if (Path[1] = '\') and (Path[2] = '\') then // UNC path
    begin
      if CountAntiSlash > 3 then
        Result := Copy(Path, 1, iLastAntiSlash);
    end else
    begin
      if CountAntiSlash > 1 then
        Result := Copy(Path, 1, iLastAntiSlash);
    end;
  end else Result := Path;
end;

//------------------------------------------------------------------//
//目录比较,无论路径大小写及路径格式
function DirCompare(const Path1, Path2: string): Boolean;
begin
  Result := AnsiCompareFileName(DelSlash(Path1), DelSlash(Path2)) = 0;
end;

//------------------------------------------------------------------//
//目录文件枚举，对sDir目录下的每一文件或目录调用DirEnumProc过程，
//sMask：指定一类文件，如'*.txt'；
//Attr ：指定目录文件属性；faReadOnly,faHidden,faSysFile,faVolumeID,faDirectory,faArchive,faAnyFile
procedure DirEnum(sDir, sMask: string; Attr: Integer; DirEnumProc: TDirEnumProc);
var
  SearchRec: TSearchRec;
  Status   : Integer;
  bContinue: Boolean;
begin
  sDir := AddSlash(sDir);

  // traverse child directories
  Status := FindFirst(sDir + '*.*', faDirectory, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
        DirEnum(sDir + SearchRec.name, SMASK, Attr, DirEnumProc);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;

  // exam each valid file and invoke the callback func
  Status := FindFirst(sDir + SMASK, faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.Attr and Attr <> 0) and (FileExists(sDir + SearchRec.name) or DirectoryExists(sDir + SearchRec.name)) and
        not ((SearchRec.Attr and faDirectory <> 0) and ((SearchRec.name = '.') or (SearchRec.name = '..'))) then
      begin
        bContinue := True;
        DirEnumProc(sDir + SearchRec.name, bContinue);
        if not bContinue then Break;
      end;

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

//------------------------------------------------------------------//
//目录清除子过程，被DirClean调用
procedure DirCleanProc(sFileName: string; var bContinue: Boolean);
var
  Attr: Integer;
begin
  Attr := FileGetAttr(sFileName);
  Attr := (not faReadOnly) and Attr; // Turn off ReadOnly attribute
  Attr := (not faHidden) and Attr; // Turn off Hidden attribute
  FileSetAttr(sFileName, Attr);

  if Attr and faDirectory <> 0 then RMDir(sFileName)
  else SysUtils.DeleteFile(sFileName);
end;

//------------------------------------------------------------------//
//目录清除，将目录下的所有子目录及文件清除
procedure DirClean(sDir: string);
begin
    try
      DirEnum(sDir, '*.*', faAnyFile, DirCleanProc);
    finally
    end;
    RMDir(sDir);
end;

//------------------------------------------------------------------//
//目录复制，将sDir下的所有文件复制到tDir，若bRecursive = True则包括子目录复制
procedure DirCopy(sDir, tDir: string; bRecursive: Boolean =True);
var
  SearchRec: TSearchRec;
  Status   : Integer;
begin
  sDir := AddSlash(sDir);
  tDir := AddSlash(tDir);

  Status := FindFirst(sDir + '*.*', faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if bRecursive and (SearchRec.Attr and faDirectory = faDirectory) then
      begin
        if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
          DirCopy(sDir + SearchRec.name, tDir, bRecursive);
      end else CopyFile(PChar(sDir + SearchRec.name), PChar(tDir + SearchRec.name), False);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

//------------------------------------------------------------------//
//取得盘符，sPath将成为无盘符的路径
//如c:\windows\system，返回c      ，sPath=windows\system
//如   windows\system，返回windows，sPath=system
//如  \windows\system，返回空     ，sPath=windows\system
function GetRootDir(var sPath: string): string;
var
  I: Integer;
begin
  I := AnsiPos('\', sPath);
  if I <> 0 then
    Result := Copy(sPath, 1, I)
  else
    Result := sPath;

  Delete(sPath, 1, Length(Result));
  Result := DelSlash(Result);
end;

//------------------------------------------------------------------//
//取得指定路径最下层路径，sPath成为返回路径的父路径
//如c:\windows\system，返回system ，sPath=c:\windows\
//如          \system，返回system ，sPath=空
//如           system，返回system ，sPath=空
function GetLeafDir(var sPath: string): string;
begin
  sPath := DelSlash(sPath);
  Result := ExtractFileName(sPath);
  sPath := ExtractFilePath(sPath);
end;

//------------------------------------------------------------------//
//取得系统目录路径，追加\
function GetSystemDir: string;
var
    Buf: array[0..255] of Char;
begin
    GetSystemDirectory(@Buf, 255);
    Result := AddSlash(StrPas(@Buf));
end;

//------------------------------------------------------------------//
//取得Windows目录路径，追加\
function GetWindowsDir: string;
var
    Buf: array[0..255] of Char;
begin
    GetWindowsDirectory(@Buf, 255);
    Result := AddSlash(StrPas(@Buf));
end;

//------------------------------------------------------------------//
//取得Windows所在目录路径的文件名
function GetWindowsDirFile(const sFileName: string): string;
var
    Buf: array[0..255] of Char;
begin
    GetWindowsDirectory(@Buf, 255);
    Result := AddSlash(StrPas(@Buf)) + sFileName;
end;

//------------------------------------------------------------------//
//取得系统所在目录路径的文件名
function GetSystemDirFile(const sFileName: string): string;
var
    Buf: array[0..255] of Char;
begin
    GetSystemDirectory(@Buf, 255);
    Result := AddSlash(StrPas(@Buf)) + sFileName;
end;

//------------------------------------------------------------------//
//取得系统所在驱动器目录路径的文件名
function GetSystemDriveFile(const sFileName: string): string;
var
    Buf: array[0..255] of Char;
begin
    GetSystemDirectory(@Buf, 255);
    Result := AddSlash(ExtractFileDrive(StrPas(@Buf))) + sFileName;
end;

//------------------------------------------------------------------//
//取得唯一文件名
function GetUniqFile(const Path: string; sFileName: string): string;
var
  I   : Integer;
  sExt: string;
begin
  Result := sFileName;

  sExt := ExtractFileExt(sFileName);
  sFileName := GetMainFilePath(sFileName);

  I := 1;
  repeat
    if not FileExists(AddSlash(Path) + Result) then Break;

    Result := sFileName + IntToStr(I) + sExt;
    Inc(I);
  until False;

  Result := AddSlash(Path) + sFileName + sExt;
end;

//------------------------------------------------------------------//
//取得临时文件名
function GetTempFile(sPrefix: string = 'TEMP'): string;
var
  Buf: array[0..MAX_PATH] of char;
  Temp: array[0..MAX_PATH] of char;
begin
  GetTempPath(MAX_PATH, Buf);
  GetTempFilename(Buf, PChar(sPrefix), 0, Temp);
  Result := String(Temp);
end;

//------------------------------------------------------------------//
//处理文件内图标的指示字符串，若要指向FOO.DLL的第2个图标，会以"FOO.DLL,1"
//表示(编号从零开始)。TruncateTrailNumber将逗号及逗号以后的编号去掉。形成：
//"FOO.DLL"
function TruncateTrailNumber(var S: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  
  I := Pos(',', S);
  if I <> 0 then
  begin
    Result := StrToIntDef(Copy(S, I + 1, Length(S)), - 1);
    Delete(S, I, Length(S));
  end;
end;

//------------------------------------------------------------------//
//TruncateTrailIfNotDLL判断此文件是否为EXE、DLL、ICL等可能带有图标的文件，
//若是，才保留图标编号。
function TruncateTrailIfNotDLL(S: string): string;
begin
  Result := S;
  TruncateTrailNumber(S);
  
  if (CompareText(ExtractFileExt(S), '.DLL') <> 0) and
    (CompareText(ExtractFileExt(S), '.ICL') <> 0) and
    (CompareText(ExtractFileExt(S), '.EXE') <> 0) then Result := S;
end;

//------------------------------------------------------------------//
//判断包含图标的文件是否存在。如："FOO.DLL,1"，检查FOO.DLL是否存在。
function FileExistsAfterTruncate(Filename: string): Boolean;
begin
  TruncateTrailNumber(Filename);
  Result := FileExists(Filename);
end;

initialization
  GetDir(0, AppDir);
  AppDir := AddSlash(AppDir);
end.