commonfun.pas

res可视化压缩

{* |<PRE>
================================================================================
** 单元名称：系统公共函数库
** 单元作者：胡昌洪 (HCH)
** 备    注：
**           基础函数重载,实现数据格式非法时的容错处理
**
** 开发平台：PWinXP SP2 + Delphi 7
** 兼容测试：PWin9X/2000/XP/2003 + Delphi 7-10
** 本 地 化：该单元中的字符串均符合本地化处理方式
** 单元标识：$Id: CommonFun.pas,v 1.0 2008-06-05 15:49:44 sesame Exp $
** 修改记录：
**           2008-06-05
**              创建单元
================================================================================
|</PRE>}
unit CommonFun;

interface

uses
  Windows, Sysutils, Classes, Dialogs, Controls, Registry, ShellAPI, Forms,
  DDEman, Messages, TlHelp32, ShlObj, ActiveX;

const
  ClientRegRoot = '\SOFTWARE\HCH Software\XYOSWin_M\2.0\Client';

var
  OldPath: string;
  MainHandle: THandle;
  DateTimeFormatSet: TFormatSettings;

type
  TFileInfo = record //文件版本相关信息
    CommpanyName: string; //组织名称
    FileDescription: string; //文件描述
    FileVersion: string; //版本号
    InternalName: string; //内部名称
    LegalCopyright: string; //法定版权
    LegalTrademarks: string; //法定商标
    OriginalFileName: string; //原始文件名
    ProductName: string; //产品名称
    ProductVersion: string; //产品主版本号
    Comments: string; //注释
    UserDefineValue: string; //用户自定义
    ModifyDateTime: string; //最后修改日期
    VsFixedFileInfo: VS_FIXEDFILEINFO;//修正版本号
    LastModifyDate: string;//最后修改日期
    Remark: string; //备注信息
  end;

function Msgbox(const sMsg: string; const sTitle: string = '提示';
  const bAnswer: Boolean = False; DefBut: Integer = 1): Boolean;

//路径尾部加反斜杠('\')
function PathWithBackslash(Path: string): string;
//路径最后没有'/'则加'/'
function PathWithSlash(const Path: string; aPIX: string = '\'): string;
//获取系统临时文件夹
function GetSysTempPath: string;
//返回Windows 的启动路径
function GetWindowsDirectory: string;
//返回ProgramFiles 的路径
function GetProgramFilesPath: string;
//获取系统目录
function GetSystemDir: string;
//判断文件是否正在使用
function IsFileInUse(FName: string): Boolean;
//删除文件
function DelFile(aFile: string): boolean;
// 删除整个目录
function Deltree(Dir: string): Boolean;
//在目录及其子目录中查找文件
function SearchFile(mainpath: string; filename: string; var foundresult:
  TStringList; Mode: integer = 1; aSubDir: boolean = True): Boolean;
//取相对路径
function GetRelativePath(Source, Dest: string): string;
//拷贝文件
function CopyFileEx(sFile, sNewFile: string; bExists: boolean = False): boolean;
//获取进程列表
procedure SystemTaskList(aList: TStringList);
//自杀
function KillMe(aAppName: string): Boolean;
//杀进程
function KillTask(TaskName: string): Byte;
//运行外部应用程序
procedure RunFile(sFileName: string; sPara: pchar = nil; nShowCmd: Integer =
  sw_shownormal);
//添加程序到系统自动运行任务中去
procedure AddToAutoRun(aAppName, aFileName:string);
//关闭IE浏览器
procedure CloseIE;
//获取浏览器地址栏信息及标题
function URLInfo(sBrowerPrgFile, sServiceName: string; Netscape: boolean; var
  Title: string): pChar;
//取文件日期
function GetFileDate(aFileName: string): string;
function SetFileDate(aFileName: string; aNewDate: string): Boolean;
function GetFileLength(aFilename: string): integer;
//文件更名
function ReFileName(aSFile, aDFile: string; var aMsg: string): Boolean;
//从资源中提取文件
function GetResFile(aTitle, aType, aOutFile, aDate: string; var aMsg: string):
  Boolean;
//获取文件版本信息
function GetFileVersionInfomation(const aFileName: string; var info: TFileInfo;
  UserDefine: string = ''): Boolean;
function SelectDir(handle: hwnd; const Caption: string; var Directory: string;
  const Root: WideString = ''): Boolean;
//重新启动自己
function ReStartSelf(aUrl: string = ''): Boolean;
//从注册表读取 -字符串
function ReadRegistString(Name: string; Key: string = ClientRegRoot;
  RootKey: HKEY = HKEY_LOCAL_MACHINE; Default: string = ''): string;
//写入注册表 -字符串
procedure WriteRegistString(sReg, Value: string; Key: string =
  ClientRegRoot; RootKey: HKEY = HKEY_LOCAL_MACHINE);
//从注册表读取 -布尔形
function ReadRegistBool(Name: string; Key: string = ClientRegRoot; RootKey:
  HKEY = HKEY_LOCAL_MACHINE; Default: Boolean = False): Boolean;
//写入注册表 -布尔形
procedure WriteRegistBool(sReg: string; Value: Boolean; Key: string =
  ClientRegRoot; RootKey: HKEY = HKEY_LOCAL_MACHINE);
procedure Delay(DelayTime: longint);
function RepStr(sSource: string; iRepTime: Integer = 80): string;
function GetOSVer: string;

implementation

//重载消息提示函数,统一格式消息窗口, bAnswer是否需要回答 DefBut默认按钮
function Msgbox(const sMsg: string; const sTitle: string;
  const bAnswer: Boolean; DefBut: Integer): Boolean;
var
  Flags: Longint;
begin
  Result:=False;
  case DefBut of
    1: Flags:=MB_DEFBUTTON1;
    2: Flags:=MB_DEFBUTTON2;
    3: Flags:=MB_DEFBUTTON3;
    else
      Flags:=MB_DEFBUTTON1;
  end;
  if bAnswer then
  begin
    Flags:=Flags + MB_YESNO + MB_ICONINFORMATION + MB_TOPMOST;
    Result:=Application.MessageBox(Pchar(sMsg), Pchar(sTitle), Flags) <> mrNo;
  end
  else
  begin
    Flags:=Flags + MB_OK + MB_ICONINFORMATION + MB_TOPMOST;
    Application.MessageBox(Pchar(sMsg), Pchar(sTitle), Flags);
  end;
end;

function PathWithBackslash(Path: string): string;
var
  I: Integer;
begin
  Result:=Path;
  I:=Length(Path);
  if I = 0 then
    Exit;
  if not (Path[I] in ['\', ':']) then
    Result:=Path + '\';
end;

// 删除整个目录
function Deltree(Dir: string): Boolean;
var
  sr: TSearchRec;
  fr: Integer;
begin
  if not DirectoryExists(Dir) then
  begin
    Result:=True;
    Exit;
  end;
  fr:=FindFirst(PathWithBackslash(Dir) + '*.*', faAnyFile, sr);
  try
    while fr = 0 do
    begin
      if (sr.Name <> '.') and (sr.Name <> '..') then
      begin
        if sr.Attr and faDirectory = faDirectory then
          Result:=Deltree(PathWithBackslash(Dir) + sr.Name)
        else
          Result:=DeleteFile(PathWithBackslash(Dir) + sr.Name);
        if not Result then
          Exit;
      end;
      fr:=FindNext(sr);
    end;
  finally
    FindClose(sr);
  end;
  Result:=RemoveDir(Dir);
end;

{
参数介绍：
Mainpath： 指定的查询目录。
Filename： 欲查询的文件。(通配符方式)
Mode: 返回列表模式 1:正常,路径和文件名 2:全文件名 3:不包含扩展名
Foundresult： 返回的含完整路径的匹配文件（可能有多个）。
如果有匹配文件，函数返回True，否则，返回False;
}
function SearchFile(mainpath: string; filename: string; var foundresult:
  TStringList; Mode: integer = 1; aSubDir: boolean = True): Boolean;
var
  sr: TSearchRec;
  sTmp: string;
  i: integer;
begin
  Result:=False;
  try
    if mainpath[length(mainpath)] = '\' then
      Delete(mainpath, length(mainpath), 1);
    if FindFirst(mainpath + '\' + filename, faanyfile, sr) = 0 then
      repeat
        if (sr.name <> '.') and (sr.name <> '..') then
          if (sr.Attr and fadirectory) = fadirectory then
          begin
            if aSubDir then
              SearchFile(mainpath + '\' + sr.name, filename, foundresult);
          end
          else
          begin
            foundresult.Add(mainpath + '\' + sr.name);
            Result:=True;
          end;
      until findnext(sr) <> 0;
    findclose(sr);
    case Mode of
      1: ;
      2:
        begin
          for i:=0 to foundresult.Count - 1 do
            foundresult.Strings[i]:=ExtractFileName(foundresult.Strings[i]);
        end;
      3: for i:=0 to foundresult.Count - 1 do
        begin
          sTmp:=ExtractFileName(foundresult.Strings[i]);
          foundresult.Strings[i]:=Copy(sTmp, 1, Length(sTmp) - 4);
        end;
    end;
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//取相对路径
function GetRelativePath(Source, Dest: string): string;
begin
  Source:=UpperCase(Source);
  Dest:=UpperCase(Dest);
  Result:=ExtractRelativePath(Source, Dest);
  //比较两路径字符串是否同一盘符
  if ExtractFileDrive(Source) = ExtractFileDrive(Dest) then
    if not CompareMem(pchar(ExtractFilePath(Source)),
      pchar(ExtractFilePath(Dest)), length(ExtractFilePath(Source))) then
      Result:=copy(ExpandFileName(Dest), 3, 50);
end;
//拷贝文件
function CopyFileEx(sFile, sNewFile: string; bExists: Boolean = False): Boolean;
var
  sMsg: string;
begin
  try
    if LowerCase(ExtractFilePath(sFile)) = LowerCase(ExtractFilePath(sNewFile))
      then
      Result:=ReFileName(sFile, sNewFile, sMsg)
    else
      Result:=CopyFile(PChar(sFile), PChar(sNewFile), bExists);
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//判断文件是否正在使用
function IsFileInUse(FName: string): Boolean;
var
  HFileRes: HFILE;
begin
  Result:=False;
  if not FileExists(FName) then
    Exit;
  try
    HFileRes:=CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0,
      nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    Result:=(HFileRes = INVALID_HANDLE_VALUE);
    if not Result then
      CloseHandle(HFileRes);
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//删除文件
function DelFile(aFile: string): boolean;
begin
  Result:=True;
  if FileExists(aFile) then
  try
    Result:=DeleteFile(aFile);
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//路径最后没有 aPIX 则加 aPIX
function PathWithSlash(const Path: string; aPIX: string = '\'): string;
begin
  Result:=Path;
  if (Length(Result) > 0) and (Result[Length(Result)] <> aPIX) then
    Result:=Result + aPIX;
end;

function GetSystemDir: string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  //GetSystemDirectory(@Buf, 255);
  Result:=PathWithSlash(StrPas(@Buf));
end;

function GetSysTempPath: string;
var
  Path: array[0..Max_Path] of Char;
  ResultLength: Integer;
begin
  ResultLength:=GetTempPath(SizeOf(Path), Path);
  if (ResultLength <= Max_Path) and (ResultLength > 0) then
    Result:=StrPas(Path)
  else
    Result:= '';
end;
//返回Windows 的启动路径
function GetWindowsDirectory: string;
var
  WinBoot: array[0..255] of Char;
begin
  try
    Windows.GetWindowsDirectory(@WinBoot, 255);
    Result:=PathWithSlash(StrPas(@WinBoot));
  except
  end;
end;
//返回ProgramFiles 的路径
function GetProgramFilesPath: string;
var
  ProgramFiles: array[0..255] of Char;
begin
  try
    GetEnvironmentVariable('ProgramFiles', ProgramFiles, 255);
    Result:=PathWithSlash(StrPas(@ProgramFiles));
  except
  end;
end;

//获取系统进程列表
procedure SystemTaskList(aList: TStringList);
var
  Proc: TPROCESSENTRY32;
  Snap: THandle;
begin
  aList.Clear;
  Snap:=CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  Proc.dwSize:=SizeOf(TProcessEntry32);
  Process32First(Snap, Proc);
  repeat
    aList.Add(proc.szExeFile);
  until (not Process32Next(Snap, Proc));
end;
//自杀
function KillMe(aAppName: string): Boolean;
var
  TaskLst: TStringList;
begin
  try
    Result:=False;
    TaskLst:=TStringList.Create;
    SystemTaskList(TaskLst);
    KillTask(ExtractFileName(aAppName));
    Result:=True;
  finally
    TaskLst.Free;
  end;
end;

//杀进程
function KillTask(TaskName: string): Byte;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result:=0;
  try
    FSnapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
    ContinueLoop:=Process32First(FSnapshotHandle, FProcessEntry32);
    while integer(ContinueLoop) <> 0 do
    begin
      if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
        UpperCase(TaskName))
        or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(TaskName))) then
        Result:=Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),
          FProcessEntry32.th32ProcessID), 0));
      ContinueLoop:=Process32Next(FSnapshotHandle, FProcessEntry32);
    end;
  except
    on E: Exception do
    begin
      Result:=0;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//运行外部应用程序
procedure RunFile(sFileName: string; sPara: pchar = nil; nShowCmd: Integer =
  sw_shownormal);
begin
  MainHandle:=Application.Handle;
  Shellexecute(MainHandle, 'Open', PChar(sFileName),
    Pchar(ExtractFilePath(sFileName)), sPara, nShowCmd);
end;
//添加到自启动
procedure AddToAutoRun(aAppName, aFileName:string);
var
  RegF: TRegistry;
begin
  with RegF do
  try
    RegF:=TRegistry.Create;
    RootKey:=HKEY_LOCAL_MACHINE;
    OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', True);
    WriteString(aAppName, aFileName);
    Free;
  except
    Free;
  end;
end;

procedure CloseIE;
var
  WinHandle: HWnd;
begin
  WinHandle:=FindWindow('IEFrame', nil);
  if WinHandle <> 0 then
    ;
  PostMessage(winHandle, WM_CLOSE, 0, 0);
end;

function URLInfo(sBrowerPrgFile, sServiceName: string; Netscape: boolean; var
  Title: string): pChar;
{
参数说明:
  sBrowerPrgFile: 浏览器exe文件的完整路径名
  sServiceName:   浏览器的DDE-Service名字
                  Netscape是'Netscape',IE是'iexplore'
  Title:          返回当前网页的title
  返回值:         pChar的字符串
}
var
  DDEClientConv: TDDEClientConv;
  StartPtr, EndPtr: pchar;
  sUrl: string;
begin
  result:=#0;
  Title:= '';

  if (sBrowerPrgFile = '') or (not FileExists(sBrowerPrgFile)) then
    raise Exception.create('浏览器应用程序不存在!');

  ddeClientConv:=TDDEClientConv.Create(nil);
  try
    with ddeClientConv do
    begin
      ServiceApplication:=sBrowerPrgFile;
      SetLink(sServiceName, 'WWW_GetWindowInfo');
      StartPtr:=RequestData('0xFFFFFFFF');
    end;