commonfun.pas

res可视化压缩

  finally
    ddeClientConv.Free;
  end;

  if StartPtr <> nil then
  try
    {skip leading "}
    inc(StartPtr);
    EndPtr:=StartPtr;
    {proceed to next "}
    while (EndPtr^ <> '"') do
      inc(EndPtr);
    {terminate URL string}
    EndPtr^:=#0;
    result:=StartPtr;
    {skip ","}
    StartPtr:=EndPtr + 3;
    if Netscape then
      inc(StartPtr, 12);

    EndPtr:=StartPtr;
    if Netscape then
      while (EndPtr^ <> ']') and (EndPtr^ <> '') do
        inc(EndPtr)
    else
      while (EndPtr^ <> '"') and (EndPtr^ <> '') do
        inc(EndPtr);

    EndPtr^:=#0;
    Title:=strPas(StartPtr);
  except
    on E: Exception do
    begin
      raise Exception.Create(E.Message);
    end;
  end;
end;
//取得文件日期
function GetFileDate(aFileName: string): string;
var
  fp: Thandle;
begin
  Result:= '1900-1-1';
  if not FileExists(aFileName) then
    Exit;
  try
    fp:=FileOpen(aFileName, fmOpenRead);
    try
      Result:=DateTimetoStr(FileDateToDateTime(FileGetDate(fp)),DateTimeFormatSet);
    finally
      FileClose(fp);
    end;
  except
    on E: Exception do
    begin
      raise Exception.Create(E.Message);
    end;
  end;
end;
//设置文件日期
function SetFileDate(aFileName: string; aNewDate: string): Boolean;
var
  NewD: TDateTime;
begin
  Result:=False;
  if not FileExists(aFileName) or (Trim(aNewDate)='') then
  begin
    //Msgbox(aFileName+' 文件不存在');
    Exit;
  end;
  try
    NewD:=StrToDateTime(aNewDate,DateTimeFormatSet);
    Result:=FileSetDate(aFileName, DateTimeToFileDate(NewD)) = 0;
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//获取文件长度
function GetFileLength(aFilename: string): integer;
var
  fp: file of byte;
begin
  Result:= -1;
  if FileExists(aFilename) then
  try
    AssignFile(fp, aFilename);
    Reset(fp);
    Result:=FileSize(fp);
    CloseFile(fp);
  except
    on E: Exception do
    begin
      CloseFile(fp);
      raise Exception.Create(E.Message);
    end;
  end;
end;
//文件更名
function ReFileName(aSFile, aDFile: string; var aMsg: string): Boolean;
begin
  Result:=False;
  if not FileExists(aSFile) then
  begin
    aMsg:= '文件不存在!';
    Exit;
  end;
  if UpperCase(aSFile) = UpperCase(aDFile) then
  begin
    aMsg:= '是同一文件,不需要更名!';
    Result:=True; //此情况也算是更名成功
  end
  else
  try
    Result:=RenameFile(aSFile, aDFile);
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;
//从资源中提取文件
function GetResFile(aTitle, aType, aOutFile, aDate: string; var aMsg: string):
  Boolean;
var
  myres: tResourceStream;
  FileHandle: Integer;
begin
  try
    Result:=False;
    if FileExists(aOutFile) then
      if not DelFile(aOutFile) then //删除已经存在的文件
      begin
        aMsg:= '文件: ' + aOutFile + ' 正在使用,不能覆盖!';
        Exit;
      end;
    if not DirectoryExists(ExtractFilePath(aOutFile)) then
      if not ForceDirectories(ExtractFilePath(aOutFile)) then
        //改用创建多级目录的函数
      begin
        aMsg:= '创建目录[' + ExtractFilePath(aOutFile) + ']失败!';
        Exit;
      end;
    myres:=tresourcestream.Create(hinstance, pchar(aTitle), PChar(aType));
    try
      myres.SaveToFile(aOutFile);
      //设置文件修改日期
      FileHandle:=FileOpen(aOutFile, fmOpenWrite or fmShareDenyNone);
      if FileHandle > 0 then
        FileSetDate(FileHandle, DateTimeToFileDate(StrToDateTime(aDate,
          DateTimeFormatSet)))
      else
      begin
        aMsg:= '设置文件[' + aOutFile + ']日期失败!';
        Exit;
      end;
      FileClose(FileHandle);
      Result:=True;
    finally
      myres.Free;
    end;
  except
    on e: Exception do
    begin
      Result:=False;
      aMsg:= '解压文件[' + aOutFile + ']失败!' + e.Message;
    end;
  end;
end;
//取得文件版本信息空间及资源句柄
function GetFileVersionInfomation(const aFileName: string; var info: TFileInfo;
  UserDefine: string = ''): boolean;
const
  SFInfo = '\StringFileInfo\';
var
  VersionInfo: Pointer;
  InfoSize: DWORD;
  InfoPointer: Pointer;
  Translation: Pointer;
  VersionValue: string;
  unused: DWORD;
  FileName: string;
begin
  unused:=0;
  Result:=False;
  FileName:=aFileName;
  if IsFileInUse(FileName) then
  try
    FileName:=GetSysTempPath + ExtractFileName(aFileName) + '_';
    if FileExists(FileName) then
      DelFile(FileName);
    if not CopyFileEx(aFileName, FileName) then
      Exit;
  except
    on E: Exception do
    begin
      raise Exception.Create(E.Message);
      Exit;
    end;
  end;
  with info do
  try
    InfoSize:=GetFileVersionInfoSize(pchar(FileName), unused);
    if InfoSize > 0 then
    begin
      GetMem(VersionInfo, InfoSize);
      Result:=GetFileVersionInfo(pchar(FileName), 0, InfoSize, VersionInfo);
      if Result then
      begin
        if VerQueryValue(VersionInfo, '\VarFileInfo\Translation', Translation,
          InfoSize) then
          VersionValue:=SFInfo + IntToHex(LoWord(Longint(Translation^)), 4) +
          IntToHex(HiWord(Longint(Translation^)), 4) + '\';
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'CompanyName'),
          InfoPointer, InfoSize) then
          CommpanyName:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'FileDescription'),
          InfoPointer, InfoSize) then
          FileDescription:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'FileVersion'),
          InfoPointer, InfoSize) then
          FileVersion:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'InternalName'),
          InfoPointer, InfoSize) then
          InternalName:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'LegalCopyright'),
          InfoPointer, InfoSize) then
          LegalCopyright:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'LegalTrademarks'),
          InfoPointer, InfoSize) then
          LegalTrademarks:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'OriginalFileName'),
          InfoPointer, InfoSize) then
          OriginalFileName:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'ProductName'),
          InfoPointer, InfoSize) then
          ProductName:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'ProductVersion'),
          InfoPointer, InfoSize) then
          ProductVersion:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, pchar(VersionValue + 'Comments'),
          InfoPointer, InfoSize) then
          Comments:=string(pchar(InfoPointer));
        if VerQueryValue(VersionInfo, '\', InfoPointer, InfoSize) then
          VsFixedFileInfo:=TVSFixedFileInfo(InfoPointer^);
        if UserDefine <> '' then
        begin
          if VerQueryValue(VersionInfo, pchar(VersionValue + UserDefine),
            InfoPointer, InfoSize) then
            UserDefineValue:=string(pchar(InfoPointer));
        end;
      end;
      LastModifyDate:=GetFileDate(FileName);
      FreeMem(VersionInfo);
      if aFileName<>FileName then
        DelFile(FileName);
    end;
  except
    on E: Exception do
    begin
      Result:=False;
      FreeMem(VersionInfo);
      raise Exception.Create(E.Message);
    end;
  end;
end;

//选择目录(重载为选择窗口居于屏幕中间,Handle为窗体的句柄)
function SelectDir(handle: hwnd; const Caption: string; var Directory: string;
  const Root: WideString = ''): Boolean;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
  function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: Cardinal; lpData:
    Cardinal): integer;
    stdcall;
  begin
    if uMsg = BFFM_INITIALIZED then
      result:=SendMessage(Hwnd, BFFM_SETSELECTION, Ord(TRUE),
        Longint(PChar(OldPath)))
    else
      result:=1
  end;
begin
  Result:=False;
  try
    if not DirectoryExists(Directory) then
      Directory:= ''
    else
      OldPath:=Directory;
    FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
    if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
    begin
      Buffer:=ShellMalloc.Alloc(MAX_PATH);
      try
        RootItemIDList:=nil;
        if Root <> '' then
        begin
          SHGetDesktopFolder(IDesktopFolder);
          IDesktopFolder.ParseDisplayName(Application.Handle, nil,
            POleStr(Root), Eaten, RootItemIDList, Flags);
        end;
        with BrowseInfo do
        begin
          hwndOwner:=handle;
          pidlRoot:=RootItemIDList;
          pszDisplayName:=Buffer;
          lpszTitle:=PChar(Caption);
          ulFlags:=BIF_RETURNONLYFSDIRS;
          if Directory <> '' then
          begin
            lpfn:=@BrowseCallbackProc;
            lParam:=Integer(PChar(Directory));
          end;
        end;
        WindowList:=DisableTaskWindows(0);
        try
          ItemIDList:=ShBrowseForFolder(BrowseInfo);
        finally
          EnableTaskWindows(WindowList);
        end;
        Result:=ItemIDList <> nil;
        if Result then
        begin
          ShGetPathFromIDList(ItemIDList, Buffer);
          ShellMalloc.Free(ItemIDList);
          Directory:=Buffer;
        end;
      finally
        ShellMalloc.Free(Buffer);
      end;
    end;
  except
    on E: Exception do
    begin
      Result:=False;
      raise Exception.Create(E.Message);
    end;
  end;
end;

function ReStartSelf(aUrl: string = ''): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
begin
  FillChar(StartupInfo, Sizeof(StartupInfo), #0);
  StartupInfo.cb:=Sizeof(StartupInfo);
  CreateProcess(nil,
    PChar(Application.Exename + ' ' + aUrl),
    { pointer to command line string }
    nil, { pointer to process security attributes }
    nil, { pointer to thread security attributes }
    False, { handle inheritance flag }
    NORMAL_PRIORITY_CLASS,
    nil, { pointer to new environment block }
    nil, { pointer to current directory name, PChar}
    StartupInfo, { pointer to STARTUPINFO }
    ProcessInfo); { pointer to PROCESS_INF }
  CloseIE;
end;
//从注册表读取 -字符串
function ReadRegistString(Name: string; Key: string;
  RootKey: HKEY; Default: string): string;
var
  Reg: TRegistry;
begin
  Result:=Default;
  Reg:=TRegistry.Create;
  try
    Reg.RootKey:=RootKey;
    Reg.OpenKey(Key, false);
    Result:=Reg.ReadString(Name);
    Reg.Free;
  except
    Reg.Free;
  end;
end;
//写入注册表  sReg键名 Value 值  -字符串
procedure WriteRegistString(sReg, Value: string; Key: string; RootKey: HKEY);
var
  Reg: TRegistry;
begin
  if (sReg <> '') then
  begin
    Reg:=TRegistry.Create;
    try
      Reg.RootKey:=RootKey;
      Reg.OpenKey(Key, True);
      Reg.WriteString(sReg, Value);
      Reg.Free;
    except
      Reg.Free;
    end;
  end;
end;
//从注册表读取 -布尔形
function ReadRegistBool(Name, Key: string; RootKey: HKEY; Default: Boolean):
  Boolean;
var
  Reg: TRegistry;
begin
  Result:=Default;
  Reg:=TRegistry.Create;
  try
    Reg.RootKey:=RootKey;
    Result:=Reg.KeyExists(Key);
    if Result then
    begin
      Reg.OpenKey(Key, false);
      Result:=Reg.ReadBool(Name);
    end;
    Reg.Free;
  except
    Reg.Free;
  end;
end;
//写入注册表 -布尔形
procedure WriteRegistBool(sReg: string; Value: Boolean; Key: string; RootKey:
  HKEY);
var
  Reg: TRegistry;
begin
  if (sReg <> '') then
  begin
    Reg:=TRegistry.Create;
    try
      Reg.RootKey:=RootKey;
      Reg.OpenKey(Key, True);
      Reg.WriteBool(sReg, Value);
      Reg.Free;
    except
      Reg.Free;
    end;
  end;
end;

procedure Delay(DelayTime: longint);
var
  iNow: longint;
begin
  iNow:=GetTickCount;
  repeat
    Application.ProcessMessages;
  until ((GetTickCount - iNow) >= DelayTime)
end;
//重复字符串N次
function RepStr(sSource: string; iRepTime: Integer): string;
var
  n: Integer;
begin
  Result:= '';
  for n:=1 to iRepTime do
    Result:=Result + sSource;
end;
//获取操作系统版本
function GetOSVer: string;
var
  OSVI: OSVERSIONINFO;
  ObjSysVersion, FOSVer: string;
begin
  with OSVI do
  try
    FOSVer:='';
    OSVI.dwOSversioninfoSize:=Sizeof(OSVERSIONINFO);
    GetVersionEx(OSVI);
    ObjSysVersion:=IntToStr(dwMajorVersion) + ',' + IntToStr(dwMinorVersion) +
      ',' + IntToStr(dwBuildNumber) + ',' + IntToStr(dwPlatformId) + ',' +
      szCSDVersion;
    FOSVer:=ObjSysVersion;
  finally
    Result:=FOSVer;
  end;
end;

initialization
  with DateTimeFormatSet do
  begin
    DateSeparator:='-';
    TimeSeparator:=':';
    ShortDateFormat:='YYYY-MM-DD';
    ShortTimeFormat:='HH:NN:SS';
  end;

end.