ucommon.pas

抽象三层访问数据库示例

function GetSysDirectory: String;
var
  p: PChar;
begin
  GetMem(P, 255);
  try
    GetSystemDirectory(p, 254);
    Result := p;
    if (Result <> '') and (Result[Length(Result)] <> '\') then
      Result := Result + '\';
  finally
    FreeMem(p);
  end;
end;

function ZipFile(AZipFileName, AFileNames, AParams: string): boolean;
var
  strFileName: string;
  HZip: THandle;
  i: integer;
  FarZipFile: function(AZipFileName, AFileLists, AParams: PChar): integer; stdcall;
begin
  Result := False;
  strFileName := ExtractFilePath(GetCurrentModuleFileName) + 'EgovZip.dll';
  if not FileExists(strFileName) then
    strFileName := ExtractFileName(strFileName);
  HZip := LoadLibrary(PChar(strFileName));
  if HZip = 0 then
    exit;
  try
    FarZipFile := GetProcAddress(HZip, 'ZipFile');
    if @FarZipFile = nil then
      exit;
    Result := FarZipFile(PChar(AZipFileName), PChar(AFileNames), PChar(AParams)) <> -1;
    if ParamExists(AParams, 'DeleteFile', true) then
      for i := 0 to SubStrCount(AFileNames) do
        SysUtils.DeleteFile(CopySubStr(AFileNames, i));
  finally
    FreeLibrary(HZip);
  end;
end;

function UnZipFile(AZipFileName, AFilePath, AParams: string): boolean;
var
  strFileName: string;
  HZip: THandle;
  FarUnZipFile: function(AZipFileName, AUnZipDestPath, AParams: PChar): integer; stdcall;
begin
  Result := False;
  strFileName := ExtractFilePath(GetCurrentModuleFileName) + 'EgovZip.dll';
  if not FileExists(strFileName) then
    strFileName := ExtractFileName(strFileName);
  HZip := LoadLibrary(PChar(strFileName));
  if HZip = 0 then
    exit;
  try
    FarUnZipFile := GetProcAddress(HZip, 'UnZipFile');
    if @FarUnZipFile = nil then
      exit;
    Result := FarUnZipFile(PChar(AZipFileName), PChar(AFilePath), PChar(AParams)) <> -1;
  finally
    FreeLibrary(HZip);
  end;
end;

function DeleteDirectory(Dir: string): boolean;
var
  strDir, strFileName: string;
  SearchRec: TSearchRec;
  intFound: integer;
begin
  Result := false;
  if not DirectoryExists(Dir) then
  begin
    Result := true;
    exit;
  end;
  strDir := Dir;
  if strDir[Length(strDir)] <> '\' then
    strDir := strDir + '\';
  intFound := FindFirst(strDir + '*.*', faAnyFile and faDirectory, SearchRec);
  try
    while intFound = 0 do
    begin
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
      begin
        strFileName := strDir + SearchRec.Name;
        if DirectoryExists(strFileName) then
          DeleteDirectory(strFileName)
        else
          DeleteFile(strFileName);
      end;
      intFound := FindNext(SearchRec);
    end;
  finally
    FindClose(SearchRec);
  end;
  RemoveDir(strDir);
end;

procedure GetComputerIPName(var AIP, AName: string);
type
  TaPInAddr = array[0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: array[0..63] of char;
  I: Integer;
  GInitData: TWSADATA;
begin
  AIP := '';
  AName := '';
  WSAStartup($101, GInitData);
  GetHostName(Buffer, SizeOf(Buffer));
  AName := StrPas(@Buffer);
  phe := GetHostByName(buffer);
  if phe = nil then
    Exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  I := 0;
  while pptr^[I] <> nil do
  begin
    AIP := StrPas(inet_ntoa(pptr^[I]^));
    Inc(I);
  end;
  WSACleanup;
end;

procedure CopyStringToPChar(Source: string; Target: PChar; TargetSize: Integer);
begin
  //Target内存必须由已预先分配，并且长度为TargetSize。
  //返回的Target内容值长度为Source长度和TargetSize较小的
  //超出分配长度则被截除
  if Source = '' then
    Target^ := #0
  else
    Move(Source[1], Target^, Min(TargetSize, Length(Source) + 1));
end;

procedure CopyWideStringToPWideChar(Source: WideString; Target: PWideChar; TargetSize: Integer);
begin
  //Move(Source[1], Target^, Min(TargetSize, Length(Source) + 1));
  //Move(Source[1], Target^, TargetSize);
  if Source = '' then
    Target^ := #0
  else
    StringToWideChar(Source, Target, Min(TargetSize, Length(Source) + 1));
end;

function StringToArray(Source: string): Variant;
var
  i: integer;
  aryResult: array of string;
begin
  if Source = '' then
  begin
    SetLength(aryResult, 0);
    Result := aryResult;
    exit;
  end;
  SetLength(aryResult, SubStrCount(Source) + 1);
  for i := Low(aryResult) to High(aryResult) do
    aryResult[i] := CopySubStr(Source, i);
  Result := aryResult;
end;

function GetWideString(const s: string): WideString;
var
  arrAnsiChars: array of AnsiChar;
  arrWideChars: array of WideChar;
  nBufferSize, CodePage: Integer;
begin
  CodePage := 936;
  SetLength( arrAnsiChars, Length(s) + 1 );
  StrPLCopy( @arrAnsiChars[0], s, Length(s) );
  nBufferSize := MultiByteToWideChar( CodePage, 0, @arrAnsiChars[0], -1, nil, 0 );
  SetLength( arrWideChars, nBufferSize );
  MultiByteToWideChar( CodePage, 0, @arrAnsiChars[0], -1, @arrWideChars[0], nBufferSize + 1 );
  Result := PWideChar( @arrWideChars[0] );
end;

function GetString(const s: WideString): string;
var
  InputLength, OutputLength, CodePage: Integer;
begin
  CodePage := 936;//GBK
  InputLength := Length(s);
  OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(s), InputLength, nil, 0, nil, nil);
  SetLength(Result, OutputLength);
  WideCharToMultiByte(CodePage, 0, PWideChar(s), InputLength, PAnsiChar(Result), OutputLength, nil, nil);
end;

function GetCurrentModuleFileName: string;
var
  strCurrDir: array[0..255] of char;
begin
  GetModuleFileName(hInstance, strCurrDir, 255);
  Result := strCurrDir;
end;

function GetLastErrorCode: Integer;
begin
  Result := GlobalLastErrorCode;
end;

function GetLastErrorMessage: string;
begin
  Result := GlobalLastErrorMessage;
end;

function GetRaiseException: boolean;
begin
  Result := GlobalRaiseException;
end;

procedure SetLastErrorCode(const Value: Integer);
begin
  GlobalLastErrorCode := Value;
end;

procedure SetLastErrorMessage(const Value: string);
begin
  GlobalLastErrorMessage := Value;
end;

procedure SetRaiseException(const Value: boolean);
begin
  GlobalRaiseException := Value;
end;

procedure SetLastError(const ErrorMessage: string; const ErrorCode: Integer);
var
  intErrorCode: integer;
begin
  SetLastErrorMessage(ErrorMessage);
  intErrorCode := ErrorCode;
  if ErrorMessage = '' then
    intErrorCode := 0
  else
    if intErrorCode >= 0 then
      intErrorCode := -1;
  SetLastErrorCode(intErrorCode);
end;

procedure SetLastErrorInfo(AException: Exception; const ErrorCode: Integer);
begin
//调用此过程处需要按下方式退出当前过程
//由于SetLastErrorInfo可能受GetRaiseException影响而不抛出异常
//则需要通过Exit退出当前过程以不执行后面的代码
  if not Assigned(AException) then
    exit;
  if AException.InheritsFrom(EAbort) or (CompareText(AException.ClassName, 'EAbort') = 0) then
    SetLastError('', 0)
  else
  begin
    SetLastError(AException.Message, ErrorCode);
    if GetLastErrorMessage <> '' then
      if GetRaiseException then
        raise AException;
  end;
end;

procedure SetLastErrorInfo(const ErrorMessage: string; const ErrorCode: Integer);
begin
  SetLastError(ErrorMessage, ErrorCode);
  if GetLastErrorMessage <> '' then
    if GetRaiseException then
      SetLastErrorInfo(Exception.CreateFmt('%s', [GetLastErrorMessage]), GetLastErrorCode);
end;

procedure SetLastErrorInfo(const ErrorMessageFormat: string;
  const Args: array of const; const ErrorCode: Integer);
begin
  SetLastErrorInfo(Format(ErrorMessageFormat, Args), ErrorCode);
end;

function GetDataSetActiveIndex(DataSet: TDataSet): integer;
var
  tmpDataSource: TDataSource;
  tmpDataLink: TDataLink;
begin
  tmpDataSource := TDataSource.Create(nil);
  tmpDataLink := TDataLink.Create;
  try
    tmpDataSource.DataSet := DataSet;
    tmpDataLink.DataSource := tmpDataSource;
    if tmpDataSource.State in [dsInsert] then
      tmpDataLink.BufferCount := tmpDataSource.DataSet.RecordCount + 1
    else
      tmpDataLink.BufferCount := tmpDataSource.DataSet.RecordCount;
    Result := tmpDataLink.ActiveRecord;
  finally
    tmpDataLink.Free;
    tmpDataSource.Free;
  end;
end;

function GetDataSetFieldValue(DataSet: TDataSet; FieldNames: string; RecordIndex: Integer): Variant;
var
  tmpDataSource: TDataSource;
  tmpDataLink: TDataLink;
  i, intOldActiveRecord: integer;
  strResult: string;
begin
  result := Unassigned;
  intOldActiveRecord := -1;
  tmpDataSource := TDataSource.Create(nil);
  tmpDataLink := TDataLink.Create;
  DataSet.DisableControls;
  try
    tmpDataSource.DataSet := DataSet;
    tmpDataLink.DataSource := tmpDataSource;
    if tmpDataSource.State in [dsInsert] then
      tmpDataLink.BufferCount := tmpDataSource.DataSet.RecordCount + 1
    else
      tmpDataLink.BufferCount := tmpDataSource.DataSet.RecordCount;
    if RecordIndex <= tmpDataLink.BufferCount - 1 then
    begin
      intOldActiveRecord := tmpDataLink.ActiveRecord;
      tmpDataLink.ActiveRecord := RecordIndex;
      if Pos(';', FieldNames) = 0 then
        Result := DataSet.FieldByName(FieldNames).Value
      else
      begin
        Result := '';
        for i := 0 to SubStrCount(FieldNames)do
          Result := Result + DataSet.FieldByName(CopySubStr(FieldNames, i)).AsString + ';';
        if Result <> '' then
        begin
          strResult := Result;
          Delete(strResult, length(strResult), 1);
          Result := strResult;
        end;
      end;
    end;
  finally
    if intOldActiveRecord <> -1 then
      tmpDataLink.ActiveRecord := intOldActiveRecord;
    tmpDataLink.Free;
    tmpDataSource.Free;
    DataSet.EnableControls;
  end;
end;

function CreateClientDataSet(SourceDataSet, TargetDataSet: TCustomClientDataSet): boolean;
begin
  Result := false;
  if (SourceDataSet = nil) or (TargetDataSet = nil)
    or (SourceDataSet = TargetDataSet)
    or (not SourceDataSet.Active) or TargetDataSet.Active then
    exit;
  TargetDataSet.FieldDefs.Clear;
  TargetDataSet.FieldDefs.Assign(SourceDataSet.FieldDefs);
  TargetDataSet.CreateDataSet;
  TargetDataSet.Open;
  Result := True;
end;

procedure ClearList(List: TList; FreeItems: Boolean);
var
  i: integer;
  tmpObject: TObject;
begin
  try
    if FreeItems then
      for i := 0 to List.Count - 1 do
        if Assigned(List.Items[i]) then
          try
            TObject(List.Items[i]).Free;
            List.Items[i] := nil;
          except
          end;
  finally
    List.Clear;
  end;
end;

initialization
  GlobalLastErrorCode := 0;
  GlobalLastErrorMessage := '';
  //DLL中此值为False，OCX中此值为True
  GlobalRaiseException := false;

end.