lazarus-ccr/components/tvplanit/examples/datastores/flex/access/tools/camain.pas

unit caMain;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, odbcconn, sqldb, FileUtil, Forms, Controls, Graphics,
  Dialogs, StdCtrls, EditBtn, ComCtrls, ExtCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Bevel1: TBevel;
    BtnCreateDB: TButton;
    BtnClose: TButton;
    CbCreateVPFields: TCheckBox;
    FileNameEdit: TFileNameEdit;
    ODBCConnection1: TODBCConnection;
    Panel1: TPanel;
    Panel2: TPanel;
    RgFormat: TRadioGroup;
    SQLTransaction1: TSQLTransaction;
    StatusBar1: TStatusBar;
    procedure BtnCreateDBClick(Sender: TObject);
    procedure BtnCloseClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure RgFormatClick(Sender: TObject);
  private
    function CreateAccessDatabase(ADatabaseFile: string;
      out AErrorMsg: String): boolean;
    procedure CreateContactsTable;
    procedure CreateEventsTable;
    procedure CreateResourceTable;
    procedure CreateTasksTable;
    procedure StatusMsg(const AText: String);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

uses
  LCLType, LazFileUtils;

const
   DB_DRIVERS: array[0..1] of String = (
     'Microsoft Access Driver (*.mdb)',
     'Microsoft Access Driver (*.mdb, *.accdb)'
   );
   EXT: array[0..1] of String = (
     '.mdb',
     '.accdb'
   );

   ODBC_ADD_DSN = 1;
   ODBC_CONFIG_DSN = 2;
   ODBC_REMOVE_DSN = 3;
   ODBC_ADD_SYS_DSN = 4;
   ODBC_CONFIG_SYS_DSN = 5;
   ODBC_REMOVE_SYS_DSN = 6;
   ODBC_REMOVE_DEFAULT_DSN = 7;

function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer;
  lpszDriverString: PChar; lpszAttributes: PChar): Integer; stdcall; external 'odbccp32.dll';

function SQLInstallerError(iError: integer; pfErrorCode: PInteger;
  lpszErrorMsg: string; cbErrorMsgMax: integer; pcbErrorMsg: PInteger): integer; stdcall; external 'odbccp32.dll';


{ TForm1 }

procedure TForm1.BtnCreateDBClick(Sender: TObject);
var
  fn: String;
  errMsg: String;
begin
  if FileNameEdit.FileName = '' then
    exit;

  fn := ChangeFileExt(FilenameEdit.FileName, EXT[RgFormat.ItemIndex]);
  fn := ExpandFileNameUTF8(fn);
  if FileExistsUTF8(fn) then
    DeleteFileUTF8(fn);

  // Create empty database file
  if CreateAccessDatabase(fn, errMsg) then
    StatusMsg('Database file created')
  else begin
    MessageDlg('Database file could not be created:' + LineEnding + errMsg,
      mtError, [mbOK], 0);
    exit;
  end;

  if CbCreateVPFields.Checked then begin
    //connection
    ODBCConnection1.Driver := DB_DRIVERS[RgFormat.ItemIndex];
    ODBCConnection1.Params.Add('DBQ=' + fn);
//    ODBCConnection1.Params.Add('Locale Identifier=1031');
//    ODBCConnection1.Params.Add('ExtendedAnsiSQL=1');
//    ODBCConnection1.Params.Add('CHARSET=ansi');
    ODBCConnection1.KeepConnection := True;
    ODBCConnection1.Connected := True;

    //transaction
    SQLTransaction1.DataBase := ODBCConnection1;
    SQLTransaction1.Action := caCommit;
    SQLTransaction1.Active := True;

    // Create tables
    CreateResourceTable;
    CreateContactsTable;
    CreateEventsTable;
    CreateTasksTable;

    SQLTransaction1.Active := false;
    ODBCConnection1.Connected := false;

    Statusbar1.SimpleText := 'All tables created.';
  end;
end;

procedure TForm1.BtnCloseClick(Sender: TObject);
begin
  Close;
end;

function TForm1.CreateAccessDatabase(ADatabaseFile: string;
  out AErrorMsg: String): boolean;
var
  dbType: string;
  driver: string;
  ErrorCode, ResizeErrorMessage: integer;
  ErrorMessage: PChar;
  retCode: integer;
  L: TStrings;
begin
  Result := false;
  AErrorMsg := '';

  driver := DB_DRIVERS[rgFormat.ItemIndex];

  { With the new accdb driver,
  CREATE_DB/CREATE_DBV12 will create an .accdb format database;
  CREATE_DBV4 will create an mdb
  http://stackoverflow.com/questions/9205633/how-do-i-specify-the-odbc-access-driver-format-when-creating-the-database
  }

  case rgFormat.ItemIndex of
    0 : dbtype := 'CREATE_DB="' + ADatabaseFile + '"';
    1 : case Lowercase(ExtractFileExt(ADatabaseFile)) of
          '', '.', '.mdb': dbType := 'CREATE_DBV4="' + ADatabaseFile + '"';
          '.accdb'       : dbtype := 'CREATE_DBV12="' + ADatabaseFile + '"';
        else
          raise Exception.CreateFmt('File format "%s" not supported.', [ExtractFileExt(ADatabaseFile)]);
        end;
  end;

  retCode := SQLConfigDataSource(Hwnd(nil), ODBC_ADD_DSN, PChar(driver), PChar(dbType));
  // returns 1 in case of success, 0 in case of failure
  if retCode <> 0 then begin
    if not FileExists(ADatabaseFile) then
      AErrorMsg := 'Successful creation reported, but file not found.'
    else
      Result := true
  end else
  begin
    ErrorCode := 0;
    ResizeErrorMessage := 0;
    // todo: verify how the DLL is called - use pointers?; has not been tested.
    GetMem(ErrorMessage, 512);
    try
      SQLInstallerError(1, @ErrorCode, ErrorMessage, SizeOf(ErrorMessage), @ResizeErrorMessage);
      L := TStringList.Create;
      try
        L.Delimiter := ';';
        L.StrictDelimiter := true;
        L.DelimitedText := ErrorMessage;
        AErrorMsg := L.Text;
      finally
        L.Free;
      end;
    finally
      FreeMem(ErrorMessage);
    end;
  end;
end;

procedure TForm1.CreateContactsTable;
begin
  ODBCConnection1.ExecuteDirect(
    'CREATE TABLE Contacts ('+
      'RecordID COUNTER, ' +
      'ResourceID INTEGER,' +
      'FirstName VARCHAR(50) ,'+
      'LastName VARCHAR(50) , '+
      'Birthdate DATE, '+
      'Anniversary DATE, '+
      'Title VARCHAR(50), '+
      'Company VARCHAR(50), '+
      'Department VARCHAR(50), '+
      'Job_Position VARCHAR(30), '+
      'AddressType1 INTEGER, '+
      'Address1 VARCHAR(100), '+
      'City1 VARCHAR(50), '+
      'State1 VARCHAR(25), '+
      'Zip1 VARCHAR(10), '+
      'Country1 VARCHAR(25), '+
      'AddressType2 INTEGER, '+
      'Address2 VARCHAR(100), '+
      'City2 VARCHAR(50), '+
      'State2 VARCHAR(25), '+
      'Zip2 VARCHAR(10), '+
      'Country2 VARCHAR(25), '+
      'Notes VARCHAR, '+
      'EMail1 VARCHAR(100), '+
      'EMail2 VARCHAR(100), '+
      'EMail3 VARCHAR(100), '+
      'EMailType1 INTEGER, '+
      'EMailType2 INTEGER, '+
      'EMailType3 INTEGER, '+
      'Phone1 VARCHAR(25), '+
      'Phone2 VARCHAR(25), '+
      'Phone3 VARCHAR(25), '+
      'Phone4 VARCHAR(25), '+
      'Phone5 VARCHAR(25), '+
      'PhoneType1 INTEGER, '+
      'PhoneType2 INTEGER, '+
      'PhoneType3 INTEGER, '+
      'PhoneType4 INTEGER, '+
      'PhoneType5 INTEGER, '+
      'Website1 VARCHAR(100), '+
      'Website2 VARCHAR(100), '+
      'WebsiteType1 INTEGER, '+
      'WebsiteType2 INTEGER, '+
      'Category INTEGER, '+
      'Custom1 VARCHAR(100), '+
      'Custom2 VARCHAR(100),'+
      'Custom3 VARCHAR(100), '+
      'Custom4 VARCHAR(100) )'
    );
  ODBCConnection1.ExecuteDirect(
    'CREATE UNIQUE INDEX piCRecordID ON Contacts(RecordID) WITH PRIMARY');
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX siCResourceID ON Contacts(ResourceID)');
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX siCName ON Contacts(LastName, FirstName)' );
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX siCCompany ON Contacts(Company)');
  StatusMsg('Table "Contacts" created.');
end;

procedure TForm1.CreateEventsTable;
begin
  ODBCConnection1.ExecuteDirect(
    'CREATE TABLE Events ('+
      'RecordID COUNTER, ' +
      'ResourceID INTEGER, '+
      'StartTime DATETIME, '+
      'EndTime DATETIME, '+
      'Description VARCHAR(255), '+
      'Location VARCHAR(255), '+
      'Notes VARCHAR, ' +
      'Category INTEGER, '+
      'AllDayEvent LOGICAL, '+
      'DingPath VARCHAR(255), '+
      'AlarmSet LOGICAL, '+
      'AlarmAdvance INTEGER, '+
      'AlarmAdvanceType INTEGER, '+
      'SnoozeTime DATETIME, '+
      'RepeatCode INTEGER, '+
      'RepeatRangeEnd DATETIME, '+
      'CustomInterval INTEGER)'
  );
  ODBCConnection1.ExecuteDirect(
    'CREATE UNIQUE INDEX piERecordID ON Events(RecordID) WITH PRIMARY');
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX EResourceID ON Events(ResourceID)');
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX EStartTime ON Events(StartTime)');
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX EEndTime ON Events(EndTime)');

  StatusMsg('Table "Events" created.');
end;

procedure TForm1.CreateResourceTable;
begin
  ODBCConnection1.ExecuteDirect(
    'CREATE TABLE Resources ( '+
       'ResourceID COUNTER, ' +
       'Description VARCHAR(255), '+
       'Notes VARCHAR, '+                           // 1024 --> -
       'ImageIndex INTEGER, '+
       'ResourceActive LOGICAL, '+                  // BOOL --> LOGICAL
       'UserField0 VARCHAR(100), '+
       'UserField1 VARCHAR(100), '+
       'UserField2 VARCHAR(100), '+
       'UserField3 VARCHAR(100), '+
       'UserField4 VARCHAR(100), '+
       'UserField5 VARCHAR(100), '+
       'UserField6 VARCHAR(100), '+
       'UserField7 VARCHAR(100), '+
       'UserField8 VARCHAR(100), '+
       'UserField9 VARCHAR(100) )'
  );
  ODBCConnection1.ExecuteDirect(
    'CREATE UNIQUE INDEX piRResourceID ON Resources(ResourceID) WITH PRIMARY'
  );
  StatusMsg('Table "Resources" created.');
end;

procedure TForm1.CreateTasksTable;
begin
  ODBCConnection1.ExecuteDirect(
    'CREATE TABLE Tasks ('+
      'RecordID COUNTER, ' +
      'ResourceID INTEGER, '+
      'Complete LOGICAL, '+
      'Description VARCHAR(255), '+
      'Details VARCHAR, '+
      'CreatedOn DATETIME, '+
      'Priority INTEGER, '+
      'Category INTEGER, '+
      'CompletedOn DATETIME, '+
      'DueDate DATETIME)'
  );
  ODBCConnection1.ExecuteDirect(
    'CREATE UNIQUE INDEX piTRecordID ON Tasks(RecordID) WITH PRIMARY'
  );
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX siTDueDate ON Tasks(DueDate)'
  );
  ODBCConnection1.ExecuteDirect(
    'CREATE INDEX siTCompletedOn ON Tasks(CompletedOn)'
  );
  StatusMsg('Table "Tasks" created.');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FilenameEdit.ButtonWidth := FilenameEdit.Height;
end;

procedure TForm1.RgFormatClick(Sender: TObject);
begin
  if FilenameEdit.Filename <> '' then
    FilenameEdit.FileName := ChangeFileExt(FileNameEdit.FileName, EXT[RgFormat.ItemIndex]);
end;

procedure TForm1.StatusMsg(const AText: String);
begin
  Statusbar1.SimpleText := AText;
  Application.ProcessMessages;
end;

end.