paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

tvplanit: update datastore with Access database.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@9153 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2024-01-20 23:18:35 +00:00
parent 893bc0b962
commit a3cf578b59
11 changed files with 135 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
components/tvplanit/examples/datastores/flex/access/tools/CreateAccessDB.lpi
View File

@ -61,6 +61,9 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>

32
components/tvplanit/examples/datastores/flex/access/tools/camain.lfm
View File

@ -4,12 +4,12 @@ object Form1: TForm1
Top = 171
Width = 400
AutoSize = True
Caption = 'Access database creator'
Caption = 'Access Database Creator'
ClientHeight = 285
ClientWidth = 400
Constraints.MinWidth = 400
LCLVersion = '3.99.0.0'
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object StatusBar1: TStatusBar
Left = 0
Height = 23
@ -39,8 +39,8 @@ object Form1: TForm1
BorderSpacing.Right = 8
BorderSpacing.Bottom = 8
Caption = 'Create DB'
OnClick = BtnCreateDBClick
TabOrder = 0
OnClick = BtnCreateDBClick
end
object BtnClose: TButton
AnchorSideRight.Control = Panel1
@ -55,8 +55,8 @@ object Form1: TForm1
BorderSpacing.Right = 12
BorderSpacing.Bottom = 8
Caption = 'Close'
OnClick = BtnCloseClick
TabOrder = 1
OnClick = BtnCloseClick
end
object Bevel1: TBevel
Left = 9
@ -109,9 +109,9 @@ object Form1: TForm1
AnchorSideTop.Side = asrBottom
Left = 16
Height = 19
Top = 125
Width = 140
BorderSpacing.Top = 8
Top = 133
Width = 138
BorderSpacing.Top = 16
BorderSpacing.Bottom = 16
Caption = 'Add VisualPlanIt tables'
Checked = True
@ -125,7 +125,7 @@ object Form1: TForm1
Left = 16
Height = 62
Top = 55
Width = 267
Width = 305
AutoFill = True
AutoSize = True
BorderSpacing.Top = 16
@ -139,14 +139,14 @@ object Form1: TForm1
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 42
ClientWidth = 263
ClientWidth = 301
ItemIndex = 0
Items.Strings = (
'.mdb (Access 97, 2000, 2003), 32 bit only'
'.accdb (Access 2007+), 32 bit and 64 bit'
'Access 97, 2000, 2003), 32 bit only (*.mdb)'
'Access 2007+, 32 bit and 64 bit (*.mdb, *.accdb)'
)
OnClick = RgFormatClick
TabOrder = 2
OnClick = RgFormatClick
end
end
object ODBCConnection1: TODBCConnection
@ -154,14 +154,14 @@ object Form1: TForm1
LoginPrompt = False
KeepConnection = False
Transaction = SQLTransaction1
left = 48
top = 168
Left = 48
Top = 168
end
object SQLTransaction1: TSQLTransaction
Active = False
Action = caCommit
Database = ODBCConnection1
left = 152
top = 168
Left = 152
Top = 168
end
end

96
components/tvplanit/examples/datastores/flex/access/tools/camain.pas
View File

@ -5,8 +5,9 @@ unit caMain;
interface
uses
Classes, SysUtils, odbcconn, sqldb, FileUtil, Forms, Controls, Graphics,
Dialogs, StdCtrls, EditBtn, ComCtrls, ExtCtrls;
Classes, SysUtils, FileUtil,
Forms, Controls, Graphics, Dialogs, StdCtrls, EditBtn, ComCtrls, ExtCtrls,
odbcconn, odbcsqldyn, sqldb;
type
@ -40,6 +41,8 @@ type
{ public declarations }
end;
function Is64Bit: Boolean;
var
Form1: TForm1;
@ -74,6 +77,10 @@ function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer;
function SQLInstallerError(iError: integer; pfErrorCode: PInteger;
lpszErrorMsg: string; cbErrorMsgMax: integer; pcbErrorMsg: PInteger): integer; stdcall; external 'odbccp32.dll';
function Is64Bit: Boolean;
begin
Result := SizeOf(Pointer) = 8;
end;
{ TForm1 }
@ -85,8 +92,8 @@ begin
if FileNameEdit.FileName = '' then
exit;
fn := ChangeFileExt(FilenameEdit.FileName, EXT[RgFormat.ItemIndex]);
fn := ExpandFileNameUTF8(fn);
//fn := ChangeFileExt(FilenameEdit.FileName, EXT[RgFormat.ItemIndex]);
fn := ExpandFileNameUTF8(FileNameEdit.FileName);
if FileExistsUTF8(fn) then
DeleteFileUTF8(fn);
@ -138,7 +145,7 @@ var
dbType: string;
driver: string;
ErrorCode, ResizeErrorMessage: integer;
ErrorMessage: PChar;
ErrorMessage: String = '';
retCode: integer;
L: TStrings;
begin
@ -163,32 +170,29 @@ begin
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
retCode := SQLConfigDataSource(0, ODBC_ADD_DSN, PChar(driver), PChar(dbType));
if retCode in [SQL_SUCCESS, SQL_SUCCESS_WITH_INFO] 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);
SetLength(ErrorMessage, SQL_MAX_MESSAGE_LENGTH);
SQLInstallerError(1, @ErrorCode, PChar(ErrorMessage), Length(ErrorMessage), @ResizeErrorMessage);
SetLength(ErrorMessage, ResizeErrorMessage);
L := TStringList.Create;
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;
L.Delimiter := ';';
L.StrictDelimiter := true;
L.DelimitedText := ErrorMessage;
AErrorMsg := L.Text;
finally
FreeMem(ErrorMessage);
L.Free;
end;
end;
end;
@ -201,6 +205,7 @@ begin
'ResourceID INTEGER,' +
'FirstName VARCHAR(50) ,'+
'LastName VARCHAR(50) , '+
'Category INTEGER, '+
'Birthdate DATE, '+
'Anniversary DATE, '+
'Title VARCHAR(50), '+
@ -240,11 +245,20 @@ begin
'Website2 VARCHAR(100), '+
'WebsiteType1 INTEGER, '+
'WebsiteType2 INTEGER, '+
'Category INTEGER, '+
'Custom1 VARCHAR(100), '+
'Custom2 VARCHAR(100),'+
'Custom3 VARCHAR(100), '+
'Custom4 VARCHAR(100) )'
'Custom4 VARCHAR(100), '+
'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 piCRecordID ON Contacts(RecordID) WITH PRIMARY');
@ -277,7 +291,17 @@ begin
'SnoozeTime DATETIME, '+
'RepeatCode INTEGER, '+
'RepeatRangeEnd DATETIME, '+
'CustomInterval INTEGER)'
'CustomInterval INTEGER, '+
'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 piERecordID ON Events(RecordID) WITH PRIMARY');
@ -330,7 +354,17 @@ begin
'Priority INTEGER, '+
'Category INTEGER, '+
'CompletedOn DATETIME, '+
'DueDate DATETIME)'
'DueDate DATETIME, '+
'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 piTRecordID ON Tasks(RecordID) WITH PRIMARY'
@ -347,10 +381,22 @@ end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FilenameEdit.ButtonWidth := FilenameEdit.Height;
if Is64Bit then
begin
RgFormat.ItemIndex := 1;
RgFormat.Controls[0].Enabled := false;
end;
end;
procedure TForm1.RgFormatClick(Sender: TObject);
begin
if Is64Bit and (RgFormat.itemIndex = 0) then
begin
RgFormat.ItemIndex := 1;
MessageDlg('Access-97 format not supported by 64-bit application.', mtError, [mbOk], 0);
end;
if FilenameEdit.Filename <> '' then
FilenameEdit.FileName := ChangeFileExt(FileNameEdit.FileName, EXT[RgFormat.ItemIndex]);
end;

4
components/tvplanit/examples/datastores/flex/access/unit1.pas
View File

@ -3,8 +3,8 @@ unit Unit1;
{$mode objfpc}{$H+}
// Select one of these
{$DEFINE MDB}
{.$DEFINE ACCDB}
{.$DEFINE MDB}
{$DEFINE ACCDB}
interface

19
components/tvplanit/languages/vpsr.de.po
View File

@ -487,13 +487,16 @@ msgid "Edit shape"
msgstr "Form bearbeiten"
#: vpsr.rselementalreadyexists
#, object-pascal-format
#, object-pascal-format,fuzzy
#| msgid ""
#| "An element named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
"Ein Element mit Namen %s existiert bereits.\n"
"Bitte einen anderen Namen verwenden."
"Bitte einen anderen Namen verwenden.\n"
#: vpsr.rselements
msgid "Elements:"
@ -1172,13 +1175,16 @@ msgid "&Print"
msgstr "&Drucken"
#: vpsr.rsprintformatalreadyexists
#, object-pascal-format
#, object-pascal-format,fuzzy
#| msgid ""
#| "A print template named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
"Eine Druckvorlage mit Namen %s existiert bereits.\n"
"Bitte einen anderen Namen verwenden."
"Bitte einen anderen Namen verwenden.\n"
#: vpsr.rsprintformatdesigner
msgid "Print template designer"
@ -1904,3 +1910,4 @@ msgstr "Unbekannte Achsen-Spezifikation: %s"
#: vpsr.sxmldecnotatbeg
msgid "The XML declaration must appear before the first element"
msgstr "Die XML-Deklaration muss vor dem ersten Element erscheinen"

18
components/tvplanit/languages/vpsr.en.po
View File

@ -482,13 +482,16 @@ msgid "Edit shape"
msgstr "Edit shape"
#: vpsr.rselementalreadyexists
#, object-pascal-format
#, object-pascal-format,fuzzy
#| msgid ""
#| "An element named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
#: vpsr.rselements
msgid "Elements:"
@ -1159,13 +1162,16 @@ msgid "&Print"
msgstr "&Print"
#: vpsr.rsprintformatalreadyexists
#, object-pascal-format
#, object-pascal-format,fuzzy
#| msgid ""
#| "A print template named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
#: vpsr.rsprintformatdesigner
msgid "Print template designer"

4
components/tvplanit/languages/vpsr.fi.po
View File

@ -480,7 +480,7 @@ msgstr ""
#, object-pascal-format
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rselements
@ -1163,7 +1163,7 @@ msgstr ""
#, object-pascal-format
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rsprintformatdesigner

4
components/tvplanit/languages/vpsr.fr.po
View File

@ -496,7 +496,7 @@ msgstr ""
#, object-pascal-format
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rselements
@ -1179,7 +1179,7 @@ msgstr "&Imprimer"
#, object-pascal-format
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rsprintformatdesigner

4
components/tvplanit/languages/vpsr.nl.po
View File

@ -494,7 +494,7 @@ msgstr ""
#, object-pascal-format
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rselements
@ -1177,7 +1177,7 @@ msgstr "&Printen"
#, object-pascal-format
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rsprintformatdesigner

14
components/tvplanit/languages/vpsr.pl.po
View File

@ -487,10 +487,13 @@ msgid "Edit shape"
msgstr "Edycja kształtu"
#: vpsr.rselementalreadyexists
#, object-pascal-format
#, object-pascal-format,fuzzy
#| msgid ""
#| "An element named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr "Zduplikowany element %s, użyj innej nazwy."
#: vpsr.rselements
@ -1169,10 +1172,13 @@ msgid "&Print"
msgstr "&Drukuj"
#: vpsr.rsprintformatalreadyexists
#, object-pascal-format, fuzzy, badformat
#, object-pascal-format,fuzzy,badformat
#| msgid ""
#| "A print template named %s already exists.\n"
#| "Please use a different name.\n"
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr "Proszę użyć inną nazwę"
#: vpsr.rsprintformatdesigner

4
components/tvplanit/languages/vpsr.ru.po
View File

@ -490,7 +490,7 @@ msgstr ""
#, object-pascal-format
msgid ""
"An element named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rselements
@ -1173,7 +1173,7 @@ msgstr "Печать"
#, object-pascal-format
msgid ""
"A print template named %s already exists.\n"
"Please use a different name."
"Please use a different name.\n"
msgstr ""
#: vpsr.rsprintformatdesigner