DELPHI/Часто задаваемые вопросы и ответы на них/Разработка баз данных

Записываем в 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.
Источник получения информации: http://www.delphiworld.narod.ru