pathfile.pas

为青岛一家公司做的条码打印管理

{
   例程作者：李龙武。版权归 lodgue 所有   1999-12-1
   例程说明：
}
unit PathFile;

interface

uses
  Windows,SysUtils,ShellAPI,StrProcess,classes;
const
   InvalidPath=' is invalid Path!';
type
  EPathError=class(exception);
  TDriverSet=set of char;
procedure EPath(value,ErrorInfo:string);

{路径处理/文件名}
function IsValidFileName(FileName:string):boolean; //检查文件是否合法。
function IsPathWithBackslashChar(Directory:string):boolean; //判断路径尾是否存在'\'
function RectifyPath(Directory:string):string; //校正路径有'\'则不加'\'，无则加上'\'
function GetFileNameFromFullFileName(FullFileName:string):string;//从一个带有路径的文件名中读取文件名-不带有路径
function GetPathFromFullFileName(FullFileName:string):string;//从一个带有路径的文件名中读取路径-不带有文件名，后带有‘\’
function GetLongName(ShortName:string):string;//根据短文件名(8.3)获取长文件名 一个文件名/目录
function GetShortName(LongName:string):string;//根据长文件名获取断文件名(8.3) 一个文件名/目录
procedure ShortToLong(ShortName:string;var LongName:string);//将完整（含完整的路径）的短文件文件名转换成长文件名（其中任何级目录都是长形式）
procedure LongToShort(LongName:string;var ShortName:string);//将完整（含完整的路径）的长文件文件名转换成短文件名（其中任何级目录都是短形式）
{系统路径}
function GetWinDir:string;   //获取window目录
function GetPathInWindows(path:string):string; //在window目录中查找某一目录的完整路径eg:config->c:\windows\config\
function CheckDocFileOfRegProgram(ExtendName:string):string; //查找打开某一文档的可执行程序.(含完整路径)

{驱动器和硬盘}
procedure CheckDriveSignSet(var UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet:TDriverSet);//检查整个字符(A-Z)的驱动器符号
function GetUsedDrvSign:TDriverSet; //获取被用过的驱动器字符集合
function GetUnKnownDrvSign:TDriverSet;//获取被不认识的驱动器字符集合
function GetRemainDrvSign:TDriverSet; //获取没用过的驱动器字符集合

{文件}
//文件的复制
procedure AutoCopySelf(TargetFile:string); //自动复制自己，注意该文件一定是个Exe文件


implementation

procedure EPath(value,ErrorInfo:string);
begin
 raise EpathError.Create(Value+ErrorInfo);
end;

/////////////////////////////////////////////////////////////////////////////////////
{路径处理/文件名}
function IsValidFileName(FileName:string):boolean;   //检查文件是否合法。
var
  i:integer;
  Tmp:char;
  Invalid:boolean;
begin
  Invalid:=False;
  if FileName='' then Invalid:=True;
  for i:=1 to length(FileName) do begin
    Tmp:=StrToChar(Copy(FileName,i,1));
    Invalid:=Tmp in ['\','/',':','*','?','"','<','>','|'];
    if Invalid then Break;
  end;
  Result:= not Invalid;
end;

function IsPathWithBackslashChar(Directory:string):boolean; //判断路径尾是否存在反斜杠'\'
var
  Len:integer;
  EndStr:string;
begin
  Len:=Length(Directory);
  if Directory='' then Epath(Directory,InvalidPath);
  EndStr:=Copy(Directory,Len,1);
  Result:=(StrToChar(EndStr)='\');
end;

function RectifyPath(Directory:string):string;  //校正路径有'\'则不加'\'，无则加上'\'
begin
  if not IsPathWithBackslashChar(Directory) then Insert('\',Directory,Length(Directory)+1);
  Result:=Directory;
end;

function GetFileNameFromFullFileName(FullFileName:string):string;//从一个带有路径的文件名中读取文件名-不带有路径
begin
  Result:=GetRightStr(FullFileName,'\');
end;

function GetPathFromFullFileName(FullFileName:string):string;//从一个带有路径的文件名中读取路径-不带有文件名，后带有‘\’
begin
  Result:=ReplaceRight(FullFileName,'','\');
end;

function GetLongName(ShortName:string):string;//根据短文件名(8.3)获取长文件名 一个文件名/目录
var                                           //如果是目录最后不能带‘\’.因为带上‘\’，就成了路径
  FindFileData:_WIN32_FIND_DATA;              //FindFirstFile就查不到，返回空值
begin
  if FindFirstFile(PChar(ShortName),FindFileData)<>INVALID_HANDLE_VALUE then begin
    Result:=FindFileData.cFileName;
  end else Result:='';
end;

{
 目录由长名字取短名字是为空：windows,A3w_data,A4w_data,Applog,Catroot,Command
     Config,Cursors,Drwatson,Fonts,Help,Inf,Java,Media,Pif,Samples,Sysbckup
     System, System32,Temp,Vcm,Wangsamp
 下一级目录和所有文件我没有时间去一个一个的测试。我想一般很少用到它。但很有可能它里面
 一定还有类似上面的情况的目录和文件存在。
 另外，还发现Ulead.dat目录台湾友立公司的软件cool 3d建立的一个目录
 这给我带来很大的麻烦因为用户也可以定义类似上面的目录，而我不知道这样的目录
 同一般目录有什么不同。 
}
function GetShortName(LongName:string):string;//根据长文件名获取断文件名(8.3)  一个文件名/目录，
var                                           //如果是目录最后不能带‘\’.因为带上‘\’，就成了路径
  FindFileData:_WIN32_FIND_DATA;              //FindFirstFile就查不到，返回空值
  FileName:string;//不包含路径,可以是目录
begin
  FileName:=GetFileNameFromFullFileName(LongName);
  if FindFirstFile(PChar(LongName),FindFileData)<>INVALID_HANDLE_VALUE then begin
    Result:=FindFileData.cAlternateFileName;  //注意：如果不存在长文件名则将cAlternateFileName设置为空
    if Result='' then begin //如果不存在长文件名则将原文件名（大写）返回
      Result:=AnsiUpperCase(FileName);
    end;
  end else Result:='';
end;

procedure ShortToLong(ShortName:string;var LongName:string);//将完整（含完整的路径）的短文件文件名转换成长文件名（其中任何级目录都是长形式）
var                                                         //一定是合法的路径否则一律返回空串
  InfoList:TStringList;                                     //路径的前或后的空格可以忽略。
  PartShortName,PartLongName,PriorPath:string;
  i,CurSpacePos,PriorSpacePos:integer;
  DriverType:integer;
begin  //D:\llw\Pro gram\Virus\B ak
  ShortName:=TrimBoth(ShortName,' ');
  LongName:=Copy(ShortName,1,2);
  DriverType:=GetDriveType(PChar(LongName+'\'));
  if (DriverType=0) or (DriverType=1) then begin
    LongName:='';
    Exit;
  end;
  PriorSpacePos:=Pos('\',ShortName);
  if PriorSpacePos=0 then begin
    if Length(ShortName)<=2 then LongName:=ShortName
    else LongName:='';
    Exit;
  end else begin
    if Length(ShortName)=3 then begin
      LongName:=ShortName;
      Exit;
    end;
    InfoList:=TStringList.Create;
    GetSubInfoInStr(ShortName,'\',True,InfoList);
    for i:=1 to InfoList.Count-1 do begin
      CurSpacePos:=StrToInt(InfoList.Strings[i]);
      PartShortName:=Copy(ShortName,PriorSpacePos+1,CurSpacePos-PriorSpacePos-1);
      PriorPath:=Copy(ShortName,1,PriorSpacePos);
      PartLongName:=GetLongName(PriorPath+PartShortName);
      if PartLongName='' then begin
        LongName:='';
        InfoList.Free;
        Exit;
      end;
      LongName:=LongName+'\'+PartLongName;
      PriorSpacePos:=CurSpacePos;
    end;
    PriorSpacePos:=StrToInt(InfoList.Strings[InfoList.Count-1]);
    PartShortName:=Copy(ShortName,PriorSpacePos+1,Length(ShortName)-PriorSpacePos);
    PriorPath:=Copy(ShortName,1,PriorSpacePos);
    PartLongName:=GetLongName(PriorPath+PartShortName);
    LongName:=LongName+'\'+PartLongName;
    if PartLongName='' then begin
      LongName:='';
      InfoList.Free;
      Exit;
    end;
    InfoList.Free;
  end;
end;




procedure LongToShort(LongName:string;var ShortName:string);//将完整（含完整的路径）的长文件文件名转换成短文件名（其中任何级目录都是短形式）
var                                                         //一定是合法的路径否则一律返回空串
  InfoList:TStringList;                                     //路径的前或后的空格可以忽略。
  PartShortName,PartLongName,PriorPath:string;
  i,CurSpacePos,PriorSpacePos:integer;
  DriverType:integer;
begin  //D:\llw\Pro gram\Virus\B ak
  LongName:=TrimBoth(LongName,' ');
  ShortName:=Copy(LongName,1,2);
  DriverType:=GetDriveType(PChar(ShortName+'\'));
  if (DriverType=0) or (DriverType=1) then begin
    ShortName:='';
    Exit;
  end;
  PriorSpacePos:=Pos('\',LongName);
  if PriorSpacePos=0 then begin
    if Length(LongName)<=2 then ShortName:=LongName
    else ShortName:='';
    Exit;
  end else begin
    if Length(LongName)=3 then begin
      ShortName:=LongName;
      Exit;
    end;
    InfoList:=TStringList.Create;
    GetSubInfoInStr(LongName,'\',True,InfoList);
    for i:=1 to InfoList.Count-1 do begin
      CurSpacePos:=StrToInt(InfoList.Strings[i]);
      PartLongName:=Copy(LongName,PriorSpacePos+1,CurSpacePos-PriorSpacePos-1);
      PriorPath:=Copy(LongName,1,PriorSpacePos);
      PartShortName:=GetShortName(PriorPath+PartLongName);
      if PartShortName='' then begin
        ShortName:='';
        InfoList.Free;
        Exit;
      end;
      ShortName:=ShortName+'\'+PartShortName;
      PriorSpacePos:=CurSpacePos;
    end;
    PriorSpacePos:=StrToInt(InfoList.Strings[InfoList.Count-1]);
    PartLongName:=Copy(LongName,PriorSpacePos+1,Length(LongName)-PriorSpacePos);
    PriorPath:=Copy(LongName,1,PriorSpacePos);
    PartShortName:=GetShortName(PriorPath+PartLongName);
    ShortName:=ShortName+'\'+PartShortName;
    if PartShortName='' then begin
      ShortName:='';
      InfoList.Free;
      Exit;
    end;
    InfoList.Free;
  end;
end;


/////////////////////////////////////////////////////////////////////////////////////
{系统路径}
function GetPathInWindows(path:string):string;  //在windows目录下得到一个由path指定的路径
var
  MenuPath:string;
  WinPath:string;
begin
  WinPath:=RectifyPath(GetWinDir);
  path:=RectifyPath(Path);
  MenuPath:=WinPath+path;
  Result:=MenuPath;
end;

function GetWinDir:string;  //得到windows目录路径
var
  WinPath:array [0..14]of char;
begin
  GetWindowsDirectory(@WinPath,15);
  Result:=WinPath;
  Result:=RectifyPath(Result);
end;

/////////////////////////////////////////////////////////////////////////////////////
{可执行程序}
function CheckDocFileOfRegProgram(ExtendName:string):String; //查找打开某一文档的可执行程序.(含完整路径)
var
  pExeName:Pchar;
  f:TextFile;
  pTempPath:Array[0..49]of Char;
  FileName:string;
begin
  GetTempPath(50,pTempPath);
  FileName:=string(pTempPath)+'Test.'+ExtendName;
  if not FileExists(FileName) then begin
    AssignFile(f,FileName);
    Rewrite(f);
    write(f,' ');
    CloseFile(f);
    GetMem(pExeName,1024);
    FindExecutable(PChar(FileName),pTempPath,pExeName);
    Result:=String(pExeName);
    FreeMem(pExeName);
    DeleteFile(FileName);
  end else begin
    GetMem(pExeName,1024);
    FindExecutable(PChar(FileName),pTempPath,pExeName);
    Result:=String(pExeName);
    FreeMem(pExeName);
  end;
end;



/////////////////////////////////////////////////////////////////////////////////////
{关于驱动器和硬盘}
 
//驱动器
procedure CheckDriveSignSet(var UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet:TDriverSet);//检查整个字符(A-Z)的驱动器符号
var
  i:char;
  DriverType:integer;
begin
  UsedDrvSignSet:=[];
  UnKnownDrvSignSet:=[];
  NotExitsDrvSignSet:=[];
  for i:='A' to 'Z' do begin
    DriverType:=GetDriveType(PChar(string(i)+':'));
    case DriverType of
      DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,DRIVE_CDROM,DRIVE_RAMDISK:
         UsedDrvSignSet:=UsedDrvSignSet+[i];
      0: UnKnownDrvSignSet:=UnKnownDrvSignSet+[i];
      1: NotExitsDrvSignSet:=NotExitsDrvSignSet+[i];
    end;
  end;
end;

function GetUsedDrvSign:TDriverSet; //获取被用过的驱动器字符集合
var
  UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet:TDriverSet;
begin
  CheckDriveSignSet(UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet);
  Result:=UsedDrvSignSet;
end;

function GetUnKnownDrvSign:TDriverSet;  //获取被不认识的驱动器字符集合
var
  UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet:TDriverSet;
begin
  CheckDriveSignSet(UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet);
  Result:=UnKnownDrvSignSet;
end;

function GetRemainDrvSign:TDriverSet;  //获取没用过的驱动器字符集合
var
  UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet:TDriverSet;
begin
  CheckDriveSignSet(UsedDrvSignSet,UnKnownDrvSignSet,NotExitsDrvSignSet);
  Result:=NotExitsDrvSignSet;
end;

procedure AutoCopySelf(TargetFile:string); //自动复制自己，注意该文件一定是个Exe文件
var
  FullName:string;
begin
  FullName:=ParamStr(0);
  CopyFile(PChar(FullName),PChar(TargetFile),True);
end;
end.