Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 августа!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО 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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS