{*******************************************************}
{       軟件名稱: --通用--                              }
{       單元名稱: uCommon.pas                           }
{       中文名稱: 公共單元                              }
{       單元描述:                                       }
{       創    建: SamonHua                              }
{       創建日期: 2007-12-18                            }
{       修    改: 參見VSS記錄                           }
{       版權所有 (C)2002-2007 深圳壹平臺信息技術有限公司}
{*******************************************************}
unit uCommon;

interface

uses
  Windows, Messages, SysUtils, Classes, StrUtils, Variants, WinSock, Math,
  DB, DBClient;

type
  //文件版本號
  TVersionNumber = packed record
    Minor: Word;
    Major: Word;
    Build: Word;
    Release: Word;
  end;

  //取字符串中的參數值
function GetParamValue(const AParams: string; const ParamName: string; IgnoreCase: boolean = false; ASplitStr: string = ';'; AEqualStr: string = '='): string; overload;
//向字符串中寫參數值
function SetParamValue(var AParams: string; const ParamName, ParamValue: string; AddFlag: boolean = false; IgnoreCase: boolean = false; ASplitStr: string = ';'; AEqualStr: string = '='): boolean;
//檢查字符串中某參數是否存在
function ParamExists(const AParams, ParamName: string; IgnoreCase: boolean = false; ASplitStr: string = ';'; AEqualStr: string = '='): boolean;
function CopySubStr(const AParentStr: string; const AIndex: integer = 0; const ASplitStr: string = ';'; const DefStr: string = ''): string;
function SubStrCount(const AParentStr: string; const ASplitStr: string = ';'): integer; //取子串數量
procedure SearchFiles(AResultFileList: TStrings; const FilePath: string;
  const FileNameSpecifier: string = '*.*'; RecursiveSubDir: boolean = true); //查找文件
//取文件版本號
function GetFileVersionNumber(const FileName: string): TVersionNumber;
//取文件版本字符串
function GetFileVersionStr(const FileName: string): string;
function GetGUID: string;
function GetTempDirectory: string;
function GetSysDirectory: String;
function DeleteDirectory(Dir: string): boolean;
function ZipFile(AZipFileName: string; AFileNames: string; AParams: string = ''): boolean;
function UnZipFile(AZipFileName: string; AFilePath: string; AParams: string = ''): boolean;
procedure GetComputerIPName(var AIP, AName: string);
procedure CopyStringToPChar(Source: string; Target: PChar; TargetSize: Integer);
procedure CopyWideStringToPWideChar(Source: WideString; Target: PWideChar; TargetSize: Integer);
function StringToArray(Source: string): Variant;
function GetWideString(const s: string): WideString;
function GetString(const s: WideString): string;
function GetCurrentModuleFileName: string;
//異常信息處理
function GetLastErrorCode: Integer;
function GetLastErrorMessage: string;
function GetRaiseException: boolean;
procedure SetLastErrorCode(const Value: Integer);
procedure SetLastErrorMessage(const Value: string);
procedure SetLastError(const ErrorMessage: string = ''; const ErrorCode: Integer = 0);
procedure SetRaiseException(const Value: boolean);
procedure SetLastErrorInfo(AException: Exception; const ErrorCode: Integer = 0); overload;
procedure SetLastErrorInfo(const ErrorMessage: string = ''; const ErrorCode: Integer = 0); overload;
procedure SetLastErrorInfo(const ErrorMessageFormat: string; const Args: array of const; const ErrorCode: Integer = 0); overload;
//數據集操作
function GetDataSetActiveIndex(DataSet: TDataSet): integer;
function GetDataSetFieldValue(DataSet: TDataSet; FieldNames: string; RecordIndex: Integer): Variant;
function CreateClientDataSet(SourceDataSet, TargetDataSet: TCustomClientDataSet): boolean;
//清空列表對象
procedure ClearList(List: TList; FreeItems: Boolean = false);

implementation

var
  //定義DLL異常變量，而不直接把異常拋出DLL。外面無法捕獲到原始的錯誤信息。
  GlobalLastErrorCode: integer;
  GlobalLastErrorMessage: string;
  GlobalRaiseException: boolean;

function GetParamValue(const AParams, ParamName: string;
  IgnoreCase: boolean; ASplitStr, AEqualStr: string): string;
var
  strParams, strParamsOriginal, strParamName, strSplitStr, strEqualStr, strWildcard: string;
  ParamPos, EqualPos, SplitPos: integer;
begin
  //得到"abc=123;xyz=666;mnq=888"這類字符串中的某項的值,如ParamName="xyz"返回"666"
  result := '';
  strParamsOriginal := trim(AParams);
  //檢查AEqualStr的通配符(如果AEqualStr為"=",那么參數值中有"="符號就可用"=="代替),ASplitStr不支持通配符
  strWildcard := '?';
  if strWildcard = AEqualStr then
    AEqualStr := '^';
  strParamsOriginal := StringReplace(strParamsOriginal, AEqualStr + AEqualStr, DupeString(strWildcard, 5), [rfReplaceAll]);
  if IgnoreCase then
  begin
    strParams := lowercase(trim(AParams));
    strParamName := lowercase(ParamName);
    strSplitStr := lowercase(ASplitStr);
    strEqualStr := lowercase(AEqualStr);
  end
  else
  begin
    strParams := trim(AParams);
    strParamName := ParamName;
    strSplitStr := ASplitStr;
    strEqualStr := AEqualStr;
  end;
  if strParams = '' then
    exit;
  strParams := StringReplace(strParams, strEqualStr + strEqualStr, DupeString(strWildcard, 5), [rfReplaceAll]);
  if copy(strParams, 1, length(strSplitStr)) <> strSplitStr then
  begin
    strParams := strSplitStr + strParams;
    strParamsOriginal := strSplitStr + strParamsOriginal;
  end;
  if copy(strParams, length(strParams) - length(strSplitStr) - 1, length(strSplitStr)) <> strSplitStr then
  begin
    strParams := strParams + strSplitStr;
    strParamsOriginal := strParamsOriginal + strSplitStr;
  end;
  ParamPos := pos(strSplitStr + strParamName + strEqualStr, strParams); //得到參數位置
  if ParamPos = 0 then
    exit;
  delete(strParams, 1, ParamPos);
  delete(strParamsOriginal, 1, ParamPos); //對原字符串進行同樣操作
  EqualPos := pos(strEqualStr, strParams);
  delete(strParams, 1, EqualPos + length(strEqualStr) - 1);
  delete(strParamsOriginal, 1, EqualPos + length(strEqualStr) - 1);
  SplitPos := pos(strSplitStr, strParams);
  delete(strParamsOriginal, SplitPos, MaxInt); //delete(strParams, SplitPos, MaxInt);
  result := strParamsOriginal;
  result := StringReplace(result, DupeString(strWildcard, 5), AEqualStr, [rfReplaceAll]);
end;

function SetParamValue(var AParams: string; const ParamName, ParamValue: string;
  AddFlag, IgnoreCase: boolean; ASplitStr, AEqualStr: string): boolean;
var
  strParams, strParamName, strRightStr: string;
  intPos: integer;
begin
  //AParams: 源字符串,形如"a=111;b=222;c;d=333"
  //AddFlag: 字符串中沒有該參數時,true表示自動新增,false則什么都不做返回false
  //IgnoreCase: 參數名忽略大小寫
  result := false;
  if (trim(AParams) = '') and not AddFlag then
    exit;
  strParams := ASplitStr + AParams + ASplitStr;
  strParamName := ParamName;
  if IgnoreCase then
  begin
    strParams := lowercase(strParams);
    strParamName := lowercase(strParamName);
  end;
  intPos := pos(ASplitStr + strParamName + AEqualStr, strParams);
  if intPos > 0 then
  begin
    intPos := intPos - length(ASplitStr);
    strRightStr := AParams;
    delete(strRightStr, 1, intPos + length(strParamName) + 1);
    if pos(ASplitStr, strRightStr) > 0 then
      delete(strRightStr, 1, pos(ASplitStr, strRightStr) - 1)
    else
      strRightStr := '';
    AParams := copy(AParams, 1, intPos + length(strParamName) + 1) + ParamValue + strRightStr;
  end
  else if AddFlag then
  begin
    if trim(AParams) <> '' then
      AParams := AParams + ASplitStr + ParamName + AEqualStr + ParamValue
    else
      AParams := ParamName + AEqualStr + ParamValue;
  end
  else
    exit;
  result := true;
end;

function ParamExists(const AParams, ParamName: string; IgnoreCase: boolean; ASplitStr, AEqualStr: string): boolean;
var
  strParams, strParamName: string;
begin
  //AParams: 源字符串,形如"a=111;b=222;c;d=333"
  //IgnoreCase: 參數名忽略大小寫
  //如"abc=124;efg=333"和"abc;efg=333"檢查"abc"都返回True
  result := false;
  if trim(AParams) = '' then
    exit;
  strParams := ASplitStr + AParams + ASplitStr;
  strParamName := ParamName;
  if IgnoreCase then
  begin
    strParams := lowercase(strParams);
    strParamName := lowercase(strParamName);
  end;
  result := (pos(ASplitStr + strParamName + AEqualStr, strParams) > 0) or (pos(ASplitStr + strParamName + ASplitStr, strParams) > 0);
end;

function CopySubStr(const AParentStr: string; const AIndex: integer;
  const ASplitStr, DefStr: string): string;
var
  strParentStr, strSplit: string;
  i, intPos, intOldPos, intCount, intLength: integer;
begin
  result := ''; //比原有算法快
  strParentStr := AParentStr;
  if (strParentStr = '') or (AIndex < 0) then
  begin
    result := DefStr;
    exit;
  end;
  if ASplitStr = '' then
  begin
    if AIndex = 0 then
      result := strParentStr
    else
      result := '';
    exit;
  end;
  strParentStr := strParentStr + ASplitStr;
  intLength := length(strParentStr);
  strSplit := '';
  intPos := 0;
  intOldPos := 0;
  intCount := 0;
  for i := 1 to intLength do
  begin
    if strSplit <> '' then
      strSplit := strSplit + strParentStr[i]
    else if strParentStr[i] = ASplitStr[1] then
      strSplit := strParentStr[i];
    if strSplit = ASplitStr then
    begin
      inc(intCount);
      intOldPos := intPos;
      intPos := i - length(strSplit) + 1;
      strSplit := '';
    end
    else if Copy(ASplitStr, 1, length(strSplit)) <> strSplit then
      strSplit := '';
    if intCount = (AIndex + 1) then
    begin
      if AIndex > 0 then
      begin
        intPos := intPos - intOldPos - length(ASplitStr);
        intOldPos := intOldPos + length(ASplitStr);
      end
      else
      begin
        intOldPos := 1;
        intPos := intPos - 1;
      end;
      result := copy(strParentStr, intOldPos, intPos);
      break;
    end;
  end;
  if result = '' then
    result := DefStr;
end;

function SubStrCount(const AParentStr, ASplitStr: string): integer;
var
  strParentStr: string;
  i: integer;
begin
  if AParentStr = '' then
  begin
    result := -1;
    exit;
  end;
  result := 0;
  strParentStr := AParentStr;
  i := pos(ASplitStr, strParentStr);
  while i <> 0 do
  begin
    delete(strParentStr, 1, i);
    i := pos(ASplitStr, strParentStr);
    inc(result);
  end;
end;

procedure SearchFiles(AResultFileList: TStrings; const FilePath: string;
  const FileNameSpecifier: string; RecursiveSubDir: boolean);
var
  strPath: string;
  srFindFile: TSearchRec;
  procedure AddFileToList;
  begin
    if (srFindFile.Name <> '.') and (srFindFile.Name <> '..')
      and (AResultFileList.IndexOf(strPath + srFindFile.Name) = -1) then
      AResultFileList.Add(strPath + srFindFile.Name);
    //application.ProcessMessages;
  end;

  procedure SearchSubDir;
  begin
    if (srFindFile.Name <> '.') and (srFindFile.Name <> '..') and ((srFindFile.attr and fadirectory) = fadirectory) then
      SearchFiles(AResultFileList, strPath + srFindFile.Name, FileNameSpecifier, RecursiveSubDir);
  end;
begin
  //AResultFileList: 保存查找到的文件列表
  //FilePath: 查找路徑
  //FileNameSpecifier: 查找文件名
  //RecursiveSubDir: 是否遞歸子路徑
  if AResultFileList = nil then
    exit;
  if FilePath[length(FilePath)] <> '\' then
    strPath := FilePath + '\'
  else
    strPath := FilePath;
  try
    if FindFirst(strPath + FileNameSpecifier, faAnyFile and faDirectory, srFindFile) = 0 then
    begin
      AddFileToList;
      while FindNext(srFindFile) = 0 do
        AddFileToList;
    end;
  finally
    FindClose(srFindFile);
  end;
  try
    if RecursiveSubDir and (0 = FindFirst(strPath + '*', faAnyFile, srFindFile)) then
    begin
      SearchSubDir;
      while FindNext(srFindFile) = 0 do
        SearchSubDir;
    end;
  finally
    FindClose(srFindFile);
  end;
end;

function GetFileVersionNumber(const FileName: string): TVersionNumber;
var
  VersionInfoBufferSize: DWORD;
  dummyHandle: DWORD;
  VersionInfoBuffer: Pointer;
  FixedFileInfoPtr: PVSFixedFileInfo;
  VersionValueLength: UINT;
begin
  FillChar(Result, SizeOf(Result), 0);
  if not FileExists(FileName) then
    Exit;

  VersionInfoBufferSize := GetFileVersionInfoSize(PChar(FileName), dummyHandle);
  if VersionInfoBufferSize = 0 then
    Exit;

  GetMem(VersionInfoBuffer, VersionInfoBufferSize);
  try
    try
      Win32Check(GetFileVersionInfo(PChar(FileName), dummyHandle,
        VersionInfoBufferSize, VersionInfoBuffer));
      Win32Check(VerQueryValue(VersionInfoBuffer, '\',
        Pointer(FixedFileInfoPtr), VersionValueLength));
    except
      Exit;
    end;
    Result.Major := FixedFileInfoPtr^.dwFileVersionMS shr 16;
    Result.Minor := FixedFileInfoPtr^.dwFileVersionMS;
    Result.Release := FixedFileInfoPtr^.dwFileVersionLS shr 16;
    Result.Build := FixedFileInfoPtr^.dwFileVersionLS;
  finally
    FreeMem(VersionInfoBuffer);
  end;
end;

function GetFileVersionStr(const FileName: string): string;
begin
  with GetFileVersionNumber(FileName) do
    Result := Format('%d.%d.%d.%d', [Major, Minor, Release, Build]);
end;

function GetGUID: string;
var
  recGUID: TGUID;
begin
  CreateGUID(recGUID);
  Result := GUIDToString(recGUID);
end;

function GetTempDirectory: string;
var
  TempDir: array[0..255] of Char;
begin
  GetTempPath(255, @TempDir);
  Result := StrPas(TempDir);
  if (Result <> '') and (Result[Length(Result)] <> '\') then
    Result := Result + '\';
end;