Записываем в Access используя ADO

// Читаем Access`овскую базу используя ADO 
// Проверяе являеться ли файл .mdb Access
// Записываем запись в базу 
// Нужны компаненты- 
//    TADOtable,TDataSource,TOpenDialog,TDBGrid, 
//    TBitBtn,TTimer,TEditTextBox 
program
 ADOdemo; 

uses
 Forms, uMain in
 'uMain.pas' {frmMain}; 

{$R *.RES} 

begin
 
  Application.Initialize; 
  Application.CreateForm(TfrmMain, frmMain); 
  Application.Run; 
end
. 
/////////////////////////////////////////////////////////////////// 
unit
 uMain; 

interface
 
uses
 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons, 
  ComObj; 

type
 
  TfrmMain = class
(TForm) 
    DBGridUsers: TDBGrid; 
    BitBtnClose: TBitBtn; 
    DSource1: TDataSource; 
    EditTextBox: TEdit; 
    BitBtnAdd: TBitBtn; 
    TUsers: TADOTable; 
    BitBtnRefresh: TBitBtn; 
    Timer1: TTimer; 
    Button1: TButton; 
    procedure
 FormCreate(Sender: TObject); 
    procedure
 ConnectToAccessDB(lDBPathName, lsDBPassword: string
); 
    procedure
 ConnectToMSAccessDB(lsDBName, lsDBPassword: string
); 
    procedure
 AddRecordToMSAccessDB; 
    function
 CheckIfAccessDB(lDBPathName: string
): Boolean; 
    function
 GetDBPath(lsDBName: string
): string
; 
    procedure
 BitBtnAddClick(Sender: TObject); 
    procedure
 BitBtnRefreshClick(Sender: TObject); 
    procedure
 Timer1Timer(Sender: TObject); 
    function
 GetADOVersion: Double; 
    procedure
 Button1Click(Sender: TObject); 
  private
 
    { Private declarations } 
  public
 
    { Public declarations } 
  end
; 

var
 
  frmMain: TfrmMain; 
  Global_DBConnection_String: string
; 
const
 
  ERRORMESSAGE_1 = 'No Database Selected'; 
  ERRORMESSAGE_2 = 'Invalid Access Database'; 

implementation
 

{$R *.DFM} 

procedure
 TfrmMain.FormCreate(Sender: TObject); 
begin
 
  ConnectToMSAccessDB('ADODemo.MDB', '123'); // DBName,DBPassword 
end
; 

procedure
 TfrmMain.ConnectToMSAccessDB(lsDBName, lsDBPassword: string
); 
var
 
  lDBpathName: string
; 
begin
 
  lDBpathName := GetDBPath(lsDBName); 
  if
 (Trim(lDBPathName) <> '') then
 
  begin
 
    if
 CheckIfAccessDB(lDBPathName) then
 
      ConnectToAccessDB(lDBPathName, lsDBPassword); 
  end
 
  else
 
    MessageDlg(ERRORMESSAGE_1, mtInformation, [mbOK], 0); 
end
; 

function
 TfrmMain.GetDBPath(lsDBName: string
): string
; 
var
 
  lOpenDialog: TOpenDialog; 
begin
 
  lOpenDialog := TOpenDialog.Create(nil
); 
  if
 FileExists(ExtractFileDir(Application.ExeName) + '' + lsDBName) then
 
    Result := ExtractFileDir(Application.ExeName) + '' + lsDBName 
  else
 
  begin
 
    lOpenDialog.Filter := 'MS Access DB|' + lsDBName; 
    if
 lOpenDialog.Execute then
 
      Result := lOpenDialog.FileName; 
  end
; 
end
; 

procedure
 TfrmMain.ConnectToAccessDB(lDBPathName, lsDBPassword: string
); 
begin
 
  Global_DBConnection_String := 
    'Provider=Microsoft.Jet.OLEDB.4.0;' + 
    'Data Source=' + lDBPathName + ';' + 
    'Persist Security Info=False;' + 
    'Jet OLEDB:Database Password=' + lsDBPassword; 

  with
 TUsers do
 
  begin
 
    ConnectionString := Global_DBConnection_String; 
    TableName        := 'Users'; 
    Active           := True
; 
  end
; 
end
; 

// Check if it is a valid ACCESS DB File Before opening it. 

function
 TfrmMain.CheckIfAccessDB(lDBPathName: string
): Boolean; 
var
 
  UnTypedFile: file
 of
 Byte; 
  Buffer: array
[0..19] of
 Byte; 
  NumRecsRead: Integer; 
  i: Integer; 
  MyString: string
; 
begin
 
  AssignFile(UnTypedFile, lDBPathName); 
  reset(UnTypedFile,1); 
  BlockRead(UnTypedFile, Buffer, 19, NumRecsRead); 
  CloseFile(UnTypedFile); 
  for
 i := 1 to
 19 do
 MyString := MyString + Trim(Chr(Ord(Buffer[i]))); 
  Result := False
; 
  if
 Mystring = 'StandardJetDB' then
 
    Result := True
; 
  if
 Result = False
 then
 
    MessageDlg(ERRORMESSAGE_2, mtInformation, [mbOK], 0); 
end
; 

procedure
 TfrmMain.BitBtnAddClick(Sender: TObject); 
begin
 
  AddRecordToMSAccessDB; 
end
; 

procedure
 TfrmMain.AddRecordToMSAccessDB; 
var
 
  lADOQuery: TADOQuery; 
  lUniqueNumber: Integer; 
begin
 
  if
 Trim(EditTextBox.Text) <> '' then
 
  begin
 
    lADOQuery := TADOQuery.Create(nil
); 
    with
 lADOQuery do
 
    begin
 
      ConnectionString := Global_DBConnection_String; 
      SQL.Text         := 
        'SELECT Number from Users'; 
      Open; 
      Last; 
      // Generate Unique Number (AutoNumber in Access) 
      lUniqueNumber := 1 + StrToInt(FieldByName('Number').AsString); 
      Close; 
      // Insert Record into MSAccess DB using SQL 
      SQL.Text := 
        'INSERT INTO Users Values (' + 
        IntToStr(lUniqueNumber) + ',' + 
        QuotedStr(UpperCase(EditTextBox.Text)) + ',' + 
        QuotedStr(IntToStr(lUniqueNumber)) + ')'; 
      ExecSQL; 
      Close; 
      // This Refreshes the Grid Automatically 
      Timer1.Interval := 5000; 
      Timer1.Enabled  := True
; 
    end
; 
  end
; 
end
; 

procedure
 TfrmMain.BitBtnRefreshClick(Sender: TObject); 
begin
 
  Tusers.Active := False
; 
  Tusers.Active := True
; 
end
; 

procedure
 TfrmMain.Timer1Timer(Sender: TObject); 
begin
 
  Tusers.Active  := False
; 
  Tusers.Active  := True
; 
  Timer1.Enabled := False
; 
end
; 

function
 TfrmMain.GetADOVersion: Double; 
var
 
  ADO: OLEVariant; 
begin
 
  try
 
    ADO    := CreateOLEObject('adodb.connection'); 
    Result := StrToFloat(ADO.Version); 
    ADO    := Null; 
  except
 
    Result := 0.0; 
  end
; 
end
; 

procedure
 TfrmMain.Button1Click(Sender: TObject); 
begin
 
  ShowMessage(Format('ADO Version = %n', [GetADOVersion])); 
end
; 

end
.

Другое по теме:

• Использование таблиц Access
• Использование таблиц Access2
• Как можно открыть отчёт (в режиме Print Preview а также Print Direct) в MS Access