f_access.pas

劳保管理 ACCESS数据库 作为设计的一个参考

unit F_Access;

interface

uses Windows,Messages,Classes,SysUtils,Bde,DbiErrs,DbiProcs,DbiTypes,DB,DBConsts,
     DBTables,ComObj,Dialogs,Forms, Controls,StdCtrls;

  function  GetEngine(var DbEngine: Variant): Boolean;
  procedure ConfigDataBase(var DataBase1: TDataBase; Login: Boolean);
  procedure CreateAccessFields(Table1: TTable; DbDataBase,DbTable: Variant);
  function  AppendTableBde(var TableSource, TableAccess: TTable; OverWrite: Boolean): Integer;
  function  AppendTableDao(var Table1: TTable; // Table source
                           DbAccessName, // Path and name of Table target : 'C:\Tmp\NewTable.Mdb'
                           TbAccessName: String; // Table target name only: 'NewTable'
                           OverWrite: Boolean): Integer; // Overwrite: True o Append: False
  function  CopyToAccess(var Table1: TTable; DbTable: Variant): Integer;
  function  TestAlias(sAlias, sType, sPath : String): Boolean;
  procedure NewTable(var Table1: TTable);
  procedure CreateExampleTable(var Table1: TTable);
  function  QueryBDE(var Query1: TQuery; Alias,SqlFilter: String): Integer;
  function  QueryDao(var DataBase1: TDataBase; var TableSource, TableQuery: TTable;
                     DbAccessName,TbAccessName,SqlFilter: String): Integer;
  function  CompactDataBaseDao(DbAccessName: String): Boolean;
  function  RepairDataBaseDao(DbAccessName: String): Boolean;
  procedure ShowSigecom(Text: String);
  procedure InfoIndex(Table1: TTable; sIndexName: String; var IndexInfo: TComboBox);

const

  // DatabaseTypeEnum constants
  dbVersion10 = $00000001;
  dbEncrypt   = $00000002;
  dbDecrypt   = $00000004;
  dbVersion11 = $00000008;
  dbVersion20 = $00000010;
  dbVersion30 = $00000020;

  // LANGID CollatingOrderEnum constants
  dbSortNeutral = $00000400;
  dbSortArabic = $00000401;
  dbSortCyrillic = $00000419;
  dbSortCzech = $00000405;
  dbSortDutch = $00000413;
  dbSortGeneral = $00000409;
  dbSortGreek = $00000408;
  dbSortHebrew = $0000040D;
  dbSortHungarian = $0000040E;
  dbSortIcelandic = $0000040F;
  dbSortNorwdan = $00000406;
  dbSortPDXIntl = $00000409;
  dbSortPDXNor = $00000406;
  dbSortPDXSwe = $0000041D;
  dbSortPolish = $00000415;
  dbSortSpanish = $0000040A;
  dbSortSwedFin = $0000041D;
  dbSortTurkish = $0000041F;
  dbSortJapanese = $00000411;
  dbSortChineseSimplified = $00000804;
  dbSortChineseTraditional = $00000404;
  dbSortKorean = $00000412;
  dbSortThai = $0000041E;
  dbSortSlovenian = $00000424;
  dbSortUndefined = $FFFFFFFF;

  // DataTypeEnum constants
  dbBoolean = $00000001;
  dbByte = $00000002;
  dbInteger = $00000003;
  dbLong = $00000004;
  dbCurrency = $00000005;
  dbSingle = $00000006;
  dbDouble = $00000007;
  dbDate = $00000008;
  dbBinary = $00000009;
  dbText = $0000000A;
  dbLongBinary = $0000000B;
  dbMemo = $0000000C;
  dbGUID = $0000000F;
  dbBigInt = $00000010;
  dbVarBinary = $00000011;
  dbChar = $00000012;
  dbNumeric = $00000013;
  dbDecimal = $00000014;
  dbFloat = $00000015;
  dbTime = $00000016;
  dbTimeStamp = $00000017;

  // RecordsetTypeEnum constants
  dbOpenTable = $00000001;
  dbOpenDynaset = $00000002;
  dbOpenSnapshot = $00000004;
  dbOpenForwardOnly = $00000008;
  dbOpenDynamic = $00000010;

  dbSeeChanges = $00000200;

  dbPessimistic     = $00000002;
  dbOptimistic      = $00000003;
  dbOptimisticValue = $00000001;
  dbOptimisticBatch = $00000005;

  {Variables for MsAccess DataBase}
  DbLangGeneral = ';LANGID=0x0409;CP=1252;COUNTRY=0';

var
 Dir,sDataBaseName, sTableName, sAlias: String;
 TimeStart: Double;
 Hour,Min,Sec,MSec : Word;  // To measure the time until the miliseconds

implementation

function GetEngine(var DbEngine: Variant): Boolean;
begin
 Result := False;
 try
  DbEngine := CreateOleObject('Dao.DbEngine.35');
 except
  try
   DbEngine := CreateOleObject('Dao.DbEngine');
  except
   ShowMessage('Impossible to initialize DAO' + #13 +
               'The Microsoft DAO should be installed in its machine' + #13 +
               'The product is part of MS Access, Visual Basic 4/5, Ms Office, etc.');
   Screen.Cursor := crDefault;
   Exit;
  end;
 end;
 if VarType(DbEngine) = VarDispatch then Result := True;
end;

procedure ConfigDataBase(var DataBase1: TDataBase; Login: Boolean);
begin
 with DataBase1 do begin
  Close;
  DriverName   := 'MSACCESS';
  AliasName    := sAlias;
  DataBaseName := sAlias;
  LoginPrompt  := Login;
  Temporary    := True;
  Open;
 end;
end;

procedure CreateAccessFields(Table1: TTable; DbDataBase,DbTable: Variant);
var
 bActive, bControl: Boolean;
 i: Integer;
 vField{,vIndex} : Variant;
begin
 with Table1 do begin
  bActive := Active;
  if not Active then Open;
  First;

  vField := DBTable.CreateField('Tmp',dbByte);
  for i := 0 to FieldCount -1 do begin
   bControl := True;
   Case FieldDefs.Items[i].DataType of
    ftString,ftWideString:
               begin
                vField := DbTable.CreateField(FieldDefs.Items[i].Name,dbText,
                                              FieldDefs.Items[i].Size);
                vField.AllowZeroLength := True; // True: It allows the empty field, False for defect
               end;
    ftBytes:   begin
                vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbByte);
                vField.AllowZeroLength := True; // True: It allows the empty field, False for defect
               end;
    ftVarBytes: begin
                 vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbByte);
                 vField.AllowZeroLength := True; // True: It allows the empty field, False for defect
                end;
    ftMemo,
    ftFmtMemo: begin
                vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbMemo);
                vField.AllowZeroLength := True; // True: It allows the empty field, False for defect
               end;
    ftWord,
    ftSmallint: vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbInteger);
    ftInteger,
    ftAutoInc:  vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbLong);
    ftLargeInt: vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbBigInt);
    ftFloat,
    ftBCD:      vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbDouble);
    ftCurrency: vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbCurrency);
    ftBoolean : vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbBoolean);
    ftDate,
    ftDateTime: vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbDate);
    ftTime:     vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbTime);
    ftParadoxOle,
    ftDBaseOle:   vField := DBTable.CreateField(FieldDefs.Items[i].Name,dbLongBinary);
   else
    bControl := False;
   end;
    if bControl then DbTable.Fields.Append(vField);
  end;
  Active := bActive;
 end;

(*
 // Example for create an Index
 //#Ejemplo para crear un indice
 vIndex := DbTable.CreateIndex('Texto');
 vField := DBTable.CreateField('Texto',dbText,10);
 vIndex.Fields.Append(vField);
 // vIndex.Primary := True;
 // vIndex.Unique := True;
 // vIndex.Required := True;
 // vIndex.IgnoreNulls := True;
 DbTable.Indexes.Append(vIndex);
*)

 DbDataBase.TableDefs.Append(DbTable);
end;

function CopyToAccess(var Table1: TTable; DbTable: Variant): Integer;
var
 i,n: Integer;
begin
 Result := 0;

 if VarType(DbTable) <> VarDispatch then begin
  ShowMessage('We are not connected with MsAccess in' + #13 +
              'function CopyToAccess(DbTable)');
  Exit;
 end;

 with Table1 do begin
  if not Active then Open;
  n := 0;
  First;
  while not Eof do begin
   DbTable.AddNew;
   // DbTable.Edit; // For when a record is in Edit mode, the same as in Delphi
   for i := 0 to FieldCount -1 do begin
    if FieldDefs.Items[i].DataType in [ftString, ftBytes, ftVarBytes, ftWideString,
                                       ftBytes,ftVarBytes,ftMemo, ftFmtMemo,ftWideString]
     then if Length(Fields[i].AsString) > 0 then DbTable.Fields[i] := Fields[i].AsString;

    if FieldDefs.Items[i].DataType in [ftSmallint,ftInteger,ftWord,ftLargeInt,
                                       ftFloat,ftCurrency,ftBoolean,ftDate,
                                       ftTime,ftDateTime,ftParadoxOle,ftDBaseOle,
                                       ftAutoInc,ftCursor,ftADT,ftArray,ftReference,
                                       ftDataSet]
     then if Fields[i].Value <> null then DbTable.Fields[i] := Fields[i].Value;
   end;
   DbTable.Update;
   Next;
   Inc(n)
  end;
  Close;
 end;
 Result := n;
end;

function TestAlias(sAlias, sType, sPath : String): Boolean;
var
 Lista       : TStringList;
 i           : Integer;
 fConfigMode : TConfigMode;
 DbEngine,DbAccess,DbTable: Variant;
begin

{Call example:
var
 sPath, sAlias: String;
begin

 sPath := ExtractFilePath(Application.ExeName);
 if sPath[Length(sPath)] <> '\' then sPath := sPath + '\';

 sAlias := 'Customer';

 // dBase
 if not TestAlias(sAlias, 'dBase', sPath) then begin
  ShowMessage('Cannot create the alias ' + sAlias);
  Application.Terminate;
 end;

 // Paradox
 if not TestAlias(sAlias, 'Paradox', sPath) then begin
  ShowMessage('Cannot create the alias ' + sAlias);
  Application.Terminate;
 end;

 // In this case, if not exists the .mdb file, create this with Ms Dao 3.0 or 3.5
 if not TestAlias(sAlias, 'MSACCESS', sPath) then begin
  ShowMessage('Cannot create the alias ' + sAlias);
  Exit;
 end;

end;
}

 Lista  := TStringList.Create;
 Result := False;

 {To obtain those alias of the session}
 try
  Session.GetAliasNames(Lista);
 except
  Exit;
 end;

 {To look if the exists alias}
 i := 0;
 while (Length(Lista[i]) > 0) and (Lista.Count > 0) do begin
  if Lista[i] = sAlias then begin
   Result := True;
   Exit;
  end;
  if i < (Lista.Count - 1) then Inc(i) else Break;
 end;

 // To define those alias in function of the driver type
 Lista.Clear;
 sType := UpperCase(sType);
 if (sType = 'DBASE') or (sType = 'PARADOX') then begin
  Lista.Add('DEFAULT DRIVER=' + sType);

  if sType = 'PARADOX' then Lista.Add('ENABLE BCD=FALSE');
  sType := 'STANDARD';

  if sPath[Length(sPath)] = '\' then sPath := Copy(sPath,1,Length(sPath)-1);
  Lista.Add('PATH=' + sPath);
 end;

 if sType = 'MSACCESS' then begin
  Lista.Add('DATABASE NAME=' + sPath + sAlias + '.Mdb');
  Lista.Add('LANG DRIVER='+ DbLangGeneral); // DbLangGeneral
  Lista.Add('OPEN MODE=READ/WRITE');
  Lista.Add('SYSTEM DATABASE=');
  Lista.Add('USER NAME=');

  // If it does not exist the file .mdb, we create it with DAO
  if not FileExists(sPath + sAlias + '.mdb') then begin

   if not GetEngine(DbEngine) then Exit;

   try
    DbAccess := DbEngine.WorkSpaces[0];
    // Create .mdb DataBase with DAO
    DbTable := DbAccess.CreateDatabase(sPath + sAlias + '.mdb',
                                       DbLangGeneral,
                                       DbVersion30);
    DbAccess.Close;
   except
    ShowMessage('Cannot create DataBase with Dao ' + #13 +
                sPath + sAlias + '.mdb');
   end;
  end;
  // Once has created the file .mdb and the Bde Alias, it can create tables as
  // if it would be a driver standard as dBase or Paradox, with standar component
 end;

  // To create the new alias into BDE
 fConfigMode := Session.ConfigMode;
 try
  DbiInit(nil);
  Session.AddAlias(sAlias, sType, Lista);
  Session.SaveConfigFile;
 except
  Session.ConfigMode := fConfigMode;
  Exit;
 end;
 Result := True;
 ShowMessage('(c) Sigecom' + #13 +
             'http://www.arrakis.es/~sigecom' + #13 +  #13 +
             'New MsAccess Alias : ' + sAlias);
end;

procedure NewTable(var Table1: TTable);
begin
 // Posibol Fields in en dBase
 with Table1 do begin
  Close;
  TableType    := ttDefault;
  with FieldDefs do
   begin
   Clear;
   // Support in dBase and MsAccess 97
   Add('cString',      ftString,      35, False);
   Add('cSmallint',    ftSmallint,     0, False);
   Add('cInteger',     ftInteger,      0, False);
   Add('cWord',        ftWord,         0, False);
   Add('cFloat',       ftFloat,        0, False);
   Add('cCurrency',    ftCurrency,     0, False);
   Add('cBoolean',     ftBoolean,      0, False);
   Add('cBCD',         ftBcd,          0, False);
   Add('cTime',        ftTime,         0, False);
   Add('cDate',        ftDate,         0, False);
   Add('cDateTime',    ftDateTime,     0, False);
   Add('cAutoInc',     ftAutoInc,      0, False);
   Add('cBlob',        ftBlob,         0, False);
   Add('cGraphic',     ftGraphic,      0, False);
   Add('cMemo',        ftMemo,         0, False);
   Add('cFmtMemo',     ftFmtMemo,      0, False);
   Add('cFixedChar',   ftFixedChar,   10, False);
   Add('cWideString',  ftWideString,  10, False);

// Not supported in dBase
//   Add('cBytes',       ftBytes,        0, False);
//   Add('cVarBytes',    ftVarBytes,     0, False);
//   Add('cCursor',      ftCursor,       0, False);
//   Add('cLargeint',    ftLargeint,     0, False);
//   Add('cADT',         ftADT,          0, False);
//   Add('cArray',       ftArray,        0, False);
//   Add('cReference',   ftReference,    0, False);
//   Add('cDataSet',     ftDataSet,      0, False);

  end;
  with IndexDefs do begin
   Clear;
  end;
  CreateTable;
 end;
end;

procedure CreateExampleTable(var Table1: TTable);
var
 i: Integer;
begin
 // To create tables to use in the example
 if not TestAlias('AccessDao', 'MSACCESS', Dir) then begin