Tips (1541)

Tip Bewertung (20):

// Read an MS-ACCESS Database using ADO
// Verify if it is an ACCESS MDB File
// Write a Record to MS-ACCESS Database
// Components Needed on the Application Form are:-
//    TADOtable,TDataSource,TOpenDialog,TDBGrid,
//    TBitBtn,TTimer,TEditTextBox
// Date : 22/01/2002
// Author: Michael Casse.

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.