In PB mit Datenbanken geht! Wie schnell im Vergleich zu anderen System kann ich nicht beurteilen.
PB erfordert viel Handarbeit mit DB's (Datenformulare, Datengrids, Datensteuerelemente ...)
In VisualBasic oder Lazarus free Pascal ist der Komfort bei DB Anwendungen weit größer als in PB.
Was in PB aber sehr einfach ist, ist sich seinen eigen Codegenerator für DB-Formulare selbst zu erstellen.
Dazu braucht es nur ein paar Zeilen Code.
So hab ich das z.B. schon gemacht!
einfach mal in der IDE laufen lassen. Der generierte Code wird in Zwischenablage kopiert.
Code: Alles auswählen
; ===========================================================================
; FILE : DB_CodeCreater.pb
; NAME : Database Code Generator
; DESC : Generates Code for Database access
; DESC : Go to CodeStart Section, set DBName= MySQLiteDatabaseFile
; DESC : Run the this code in PureBasic-IDE, open a NEW-PureBasic File
; DESC : Goto the new PureBasic File and Press [CTRL+V] to paste
; DESC : the generated Code
; ===========================================================================
;
; AUTHOR : Stefan Maag
; DATE : 2022/05/08
; VERSION : 0.1
; COMPILER : PureBasic 5.73
; ===========================================================================
; ChangeLog:
;
; ============================================================================
EnableExplicit
Structure TDBField
ID.i
Name.s
Type.i ; DataType #PB_Database_[Long, String, Float, Double, Quad, Blob]
ByteSize.i ; FieldSize in Bytes! Das funktioniert leider nicht / noch nicht
EndStructure
Structure TDBTable
Name.s
List Fields.TDBField()
EndStructure
Global NewList DBTables.TDBTable() ; List with the Table Names
Global hDB ; DataBase Handle
Global DB_Name.s
Global NewList txt.s()
Global NewList Code.s()
#QM = Chr(34)
; Makro to add a Code-Line to the Code() List
Macro cc(CodeLine) ; cc CreateCode
AddElement(Code())
Code()=CodeLine
EndMacro
Procedure CodeToClipboard()
; ======================================================================
; NAME: CodeToClipboard
; DESC: Copy all Codelines from the List Code()
; DESC: to the Clipboard
; RET: -
; ======================================================================
Protected S.s
ResetList(Code())
ForEach Code()
S = S + Code() + #CRLF$
Next
ClearClipboard() ; Clear the Clipboard
SetClipboardText(S) ; Paste text to the clipboard..
EndProcedure
Procedure.s Get_TypeConstantName(Type)
; Returns the Name of the ConstatType as String
Select Type
Case #PB_Database_Long
ProcedureReturn "Long"
Case #PB_Database_String
ProcedureReturn "String"
Case #PB_Database_Float
ProcedureReturn "Float"
Case #PB_Database_Double
ProcedureReturn "Double"
Case #PB_Database_Quad
ProcedureReturn "Quad"
Case #PB_Database_Blob
ProcedureReturn "Blob"
EndSelect
EndProcedure
Procedure.s Get_TypeDataTye(Type)
; returns the corresponding PureBasic DataType-Defintion for a DataBase Field-Tyte
Select Type
Case #PB_Database_Long
ProcedureReturn ".l"
Case #PB_Database_String
ProcedureReturn ".s"
Case #PB_Database_Float
ProcedureReturn ".f"
Case #PB_Database_Double
ProcedureReturn ".d"
Case #PB_Database_Quad
ProcedureReturn ".q"
Case #PB_Database_Blob
ProcedureReturn ".i" ; Blob is a Binary DataField, so we must use a Pointer to a Memory
EndSelect
EndProcedure
Procedure.s GetCMD_GetDatabase(Type)
; Get the correct PureBasic Database Command for a FieldType
Select Type
Case #PB_Database_Long
ProcedureReturn "GetDatabaseLong"
Case #PB_Database_String
ProcedureReturn "GetDatabaseString"
Case #PB_Database_Float
ProcedureReturn "GetDatabaseFloat"
Case #PB_Database_Double
ProcedureReturn "GetDatabaseDouble"
Case #PB_Database_Quad
ProcedureReturn "GetDatabaseQuad"
Case #PB_Database_Blob
ProcedureReturn "GetDatabaseBlob" ; Blob is a Binary Field
EndSelect
EndProcedure
Procedure.s GetCMD_SetDatabase(Type)
; Get the correct PureBasic Database Command for a FieldType
Select Type
Case #PB_Database_Long
ProcedureReturn "SetDatabaseLong"
Case #PB_Database_String
ProcedureReturn "SetDatabaseString"
Case #PB_Database_Float
ProcedureReturn "SetDatabaseFloat"
Case #PB_Database_Double
ProcedureReturn "SetDatabaseDouble"
Case #PB_Database_Quad
ProcedureReturn "SetDatabaseQuad"
Case #PB_Database_Blob
ProcedureReturn "SetDatabaseBlob" ; Blob is a Binary Field
EndSelect
EndProcedure
Procedure Load_DBTableFields()
; ======================================================================
; NAME: Load_DBTableFields
; DESC: Add the Fields of all Database USER-Tabels to our Lists
; DESC: DBTables()\Fields()
; RET: -
; ======================================================================
Protected sSQL.s, sTab.s, sCol.s
Protected I, N
ResetList(DBTables())
ForEach DBTables()
sTab = DBTables()\Name
sSQL ="select * from " + sTab + " limit 1"
If DatabaseQuery(hDB, sSQL)
N=DatabaseColumns(hDB)
Debug sTab + " : Columns = " + Str(N)
NextDatabaseRow(hDB) ; alle Einträge durchlaufen
For I = 0 To N-1
AddElement(DBTables()\Fields())
With DBTables()\Fields()
\ID = I
\Name = DatabaseColumnName(hDB, I)
\Type = DatabaseColumnType(hdb, I) ; #PB_Database_Long, #PB_Database_Quad, #PB_Database_String, ...
; \ByteSize = DatabaseColumnSize (hdb, I) ; das funktioniert nicht!
Debug " " + Str(\ID) + " : " + \Name + " : " + Get_TypeConstantName(\Type) + " : Size =" + Str(\ByteSize)
EndWith
Next
FinishDatabaseQuery(hDB)
Else
Debug "Query Error"
EndIf
Next
EndProcedure
Procedure Load_DBTables()
; ======================================================================
; NAME: Load_DBTables
; DESC: Loads all Names of the User-Tables in the DataBase into
; DESC: our List DBTables()
; RET: Number of loaded Tables
; ======================================================================
Protected sTxt.s, sSQL.s
Protected I
; SQL Query to get a List of all User Tabels
;sSQL = "Select name FROM sqlite_master WHERE type = 'table'"
sSQL = "Select name FROM sqlite_master WHERE type IN ('table','view') And name Not LIKE 'sqlite_%' UNION ALL Select name FROM sqlite_temp_master WHERE type IN ('table','view') ORDER BY 1"
If DatabaseQuery(hDB, sSQL)
While NextDatabaseRow(hDB) ; alle Einträge durchlaufen
sTxt = GetDatabaseString(hDB, 0) ; Inhalt vom ersten Feld anzeigen
AddElement(DBTables())
DBTables()\Name = sTxt
I+1
; Debug Str(I) + " : " + sTxt
Wend
FinishDatabaseQuery(hDB)
Load_DBTableFields()
Else
Debug "Query Error"
EndIf
ProcedureReturn I
EndProcedure
;- ----------------------------------------------------------------------
;- Code Generation Procedures
;- ----------------------------------------------------------------------
Procedure PBCode_Structures(xClear=#False)
; ======================================================================
; NAME: PBCode_Structures
; DESC: Create PureBasic Code:
; DESC: Structure of each Table 'Structure [TableName]'
; RET: -
; ======================================================================
; creates Structure with all Fields in the Table
; Structure TRec_PERSON
; ID.q
; NAME.s
; VORNAME.s
; STRASSE.s
; ORT.s
; TELEFON.s
; MOBILE.s
; FAX.s
; EMAIL.s
; EndStructure
Protected sTxt.s
ResetList(DBTables())
If xClear
ClearList(Code())
EndIf
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- STRUCTURES for Recordsets")
cc(";- ----------------------------------------------------------------------")
ForEach DBTables()
sTxt = DBTables()\Name
ResetList(DBTables()\Fields())
cc("")
cc(";- " + sTxt) ; Index in the IDE's Procedure
cc("Structure TRec_" + sTxt)
With DBTables()
ResetList(\Fields())
ForEach \Fields() ; add each Field from the Table to the Structure
sTxt = \Fields()\Name + Get_TypeDataTye(\Fields()\Type)
cc(" " + sTxt)
Next
EndWith
cc("EndStructure")
Next
EndProcedure
Procedure PBCode_ReadRec(xClear=#False)
; ======================================================================
; NAME: PBCode_Structures
; DESC: Create PureBasic Code:
; DESC: for all Procedure ReadRec_[TableName]
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
ResetList(DBTables())
If xClear
ClearList(Code())
EndIf
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- PROCEDURES ReadRec")
cc(";- ----------------------------------------------------------------------")
ForEach DBTables()
sTxt = DBTables()\Name
ResetList(DBTables()\Fields())
cc("")
cc("Procedure ReadRec_"+ sTxt +"(hDB, sField.s, sVal.s, *Rec.TRec_" + sTxt +")" )
cc(" Protected ret = #True ")
cc(" Protected SQL.s ")
cc("")
sStr = "%Select * from " + sTxt + " WHERE % + sField + % = % + sVal"
sStr = ReplaceString(sStr, "%", #QM)
cc(" SQL = " + sStr)
cc("")
cc(" If DatabaseQuery(hdb,SQL) ")
cc(" If NextDatabaseRow(hDB) ")
cc(" With *Rec ")
ForEach DBTables()\Fields()
With DBTables()\Fields()
sTxt = \Name
sCmd = GetCMD_GetDatabase(\Type)
If \Type = #PB_Database_Blob
sCmd ="GetDatabaseQuad" ; ***** für BLOB noch anpassen - hat mehr Parmaeter****
sStr = " \" + \Name + " = " + sCmd + "(hdb, " + \ID + ")"
cc(sStr)
Else
sStr = " \" + \Name + " = " + sCmd + "(hdb, " + \ID + ")"
cc(sStr)
EndIf
EndWith
Next
cc(" EndWith ")
cc(" Else ")
cc(" ret = #False ")
cc(" EndIf ")
cc(" FinishDatabaseQuery(hDB) ")
cc(" Else ")
cc(" ret = #False ")
cc(" EndIf ")
cc("")
cc(" ProcedureReturn ret ")
cc("EndProcedure")
Next
EndProcedure
Procedure PBCode_WriteRec(xClear=#False)
; ======================================================================
; NAME: PBCode_WriteRec
; DESC: Create PureBasic Code:
; DESC: for all Procedure WriteRec_[TableName]
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
ResetList(DBTables())
If xClear
ClearList(Code())
EndIf
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- PROCEDURES WriteRec")
cc(";- ----------------------------------------------------------------------")
ForEach DBTables()
sTxt = DBTables()\Name
ResetList(DBTables()\Fields())
cc("")
cc("Procedure WriteRec_"+ sTxt +"(hDB, sField.s, sVal.s, *Rec.TRec_" + sTxt +")" )
cc(" Protected ret = #True ")
cc(" Protected SQL.s ")
cc("")
sStr = "%Select * from " + sTxt + " WHERE % + sField + % = % + sVal"
sStr = ReplaceString(sStr, "%", #QM)
cc(" SQL = " + sStr)
cc("")
cc(" If DatabaseQuery(hdb,SQL) ")
cc(" If NextDatabaseRow(hDB) ")
cc(" With *Rec ")
ForEach DBTables()\Fields()
With DBTables()\Fields()
sTxt = \Name
sCmd = GetCMD_SetDatabase(\Type)
If \Type = #PB_Database_Blob
sCmd ="SetDatabaseQuad" ; ***** für BLOB noch anpassen - hat mehr Parmaeter****
sStr = " " + sCmd + "(hdb, " + \ID + ", *Rec\"+ \Name + ")"
sStr = ReplaceString(sStr, "%", #QM)
Else
sStr = " \" + \Name + " = " + sCmd + "(hdb, " + \ID + ")"
; SetDatabaseXY(hdb, \ID, *Rec\Fieldame)
sStr = " " + sCmd + "(hdb, " + \ID + ", *Rec\"+ \Name + ")"
sStr = ReplaceString(sStr, "%", #QM)
cc(sStr)
EndIf
EndWith
Next
cc(" EndWith ")
cc(" Else ")
cc(" ret = #False ")
cc(" EndIf ")
cc(" FinishDatabaseQuery(hDB) ")
cc(" Else ")
cc(" ret = #False ")
cc(" EndIf ")
cc("")
cc(" ProcedureReturn ret ")
cc("EndProcedure")
Next
EndProcedure
Procedure PBCode_ReadWriteProtoypes(xClear=#False)
; ======================================================================
; NAME: PBCode_ReadWriteProtoypes
; DESC: Create PureBasic Code:
; DESC: Prototype Procedures for the Mapping ReadRec->ReadRec_[TableName],
; DESC: WriteRec->WriteRec_[TableName]
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
If xClear
ClearList(Code())
EndIf
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- PROTOTYPES")
cc(";- ----------------------------------------------------------------------")
cc("")
cc(" Prototype.i TProcDBReadRec(hDB, sField.s, sVal.s, *Rec) ")
cc(" Prototype.i TProcDBWriteRec(hDB, sField.s, sVal.s, *Rec) ")
cc("")
cc(" Global NewMap pReadRec.i() ; Pointer for all ReadRec-Functions ")
cc(" Global NewMap pWriteRec.i() ; Pointer for all WriteRec-Functions ")
cc("")
cc(" ; Add all Functions Pointer of ReadRec-, WriteRec- TabNames to the MAPs pReadRec(), pWriteRec()")
ResetList(DBTables())
ForEach DBTables()
sTxt = DBTables()\Name
cc("")
sStr = " pReadRec(%" + sTxt + "%) = @ReadRec_" + sTxt + "()"
sStr = ReplaceString(sStr, "%", #QM)
cc(sStr)
sStr = " pWriteRec(%" + sTxt + "%) = @WriteRec_" + sTxt +"()"
sStr = ReplaceString(sStr, "%", #QM)
cc(sStr)
Next
; WriteRec Protoype Procedure
cc("")
cc("Procedure ReadRec(TabName.s, hDB, sField.s, sVal.s, *Rec) ")
cc(" Protected DBReadRec.TProcDBReadRec ")
cc("")
cc(" If FindMapElement(pReadRec(), TabName) ")
cc(" DBReadRec = pReadRec() ; Get the Pointer to the correct ReadRec_[TableName]")
cc(" DBReadRec(hdb, sField, sVal, *Rec) ; Call the correct Function ReadRec_[TableName]")
cc(" EndIf")
cc("")
cc("EndProcedure")
EndProcedure
Procedure PBCode_Gadgets(TabName.s, xClear=#False)
; ======================================================================
; NAME: PBCode_Gadgets
; DESC: Create PureBasic Code:
; DESC: 1 Label and 1 TextEdit(String) Gadget for each Field in the Table
; VAR(TabName): Name of the Database Table
; VAR(xClear) : #True = Clear the Code() List first, #False= Add the Code
; RET: -
; ======================================================================
; Create PureBasic Code Editing a Record from TabName. Creats all Label and StringGadgets
Protected sTxt.s, sCmd.s, sStr.s
If xClear
ClearList(Code())
EndIf
ResetList(DBTables())
ForEach DBTables()
If DBTables()\Name = TabName
Break
EndIf
Next
sTxt = DBTables()\Name
cc( "; " + sTxt )
ResetList(DBTables()\Fields())
cc("Procedure Create_Gadgets_" + sTxt + "() ")
cc(" Protected x, y, w, h, dx, dy ")
cc("")
cc(" x= 10: y=10: w=150: h=26 ")
cc("")
cc(" dx=w+20 ")
cc(" dy=h+10 ")
cc("")
cc(" With Gadgets_" + sTxt )
ForEach DBTables()\Fields()
With DBTables()\Fields()
sStr = " \lbl_"+\Name + " = TextGadget(#PB_Any, x, y, w, h, %" + \Name +"%) ; Label"
sStr = ReplaceString(sStr, "%", #QM)
cc(sStr)
sStr = " \txt_"+\Name + " = StringGadget(#PB_Any, x+dx, y, w, h, %Text%) ; Text"
sStr = ReplaceString(sStr, "%", #QM)
cc(sStr)
cc(" y+dy ")
; cc("")
EndWith
Next
cc(" EndWith ")
cc("EndProcedure ")
EndProcedure
Procedure PBCode_GadgetStructs(TabName.s, xClear=#False)
; ======================================================================
; NAME: PBCode_GadgetStructs
; DESC: Create PureBasic Code:
; DESC: a Structure 'TGadgets_[TableName]' for Each Table which contains
; DESC: a handle for each Gadget
; VAR(TabName): Name of the Database Table
; VAR(xClear) : #True = Clear the Code() List first, #False= Add the Code
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
If xClear
ClearList(Code())
EndIf
ResetList(DBTables())
ForEach DBTables()
If DBTables()\Name = TabName
Break
EndIf
Next
sTxt = DBTables()\Name
cc( ";- " + sTxt )
ResetList(DBTables()\Fields())
; cc("")
cc("Structure TGadgets_" + sTxt +" ; Structure for Recordset Gadgets")
ForEach DBTables()\Fields()
With DBTables()\Fields()
cc(" lbl_" + \Name + ".i") ; the Label Gadget
cc(" txt_" + \Name + ".i") ; the String Gadget
EndWith
Next
cc("EndStructure")
cc("Global Gadgets_" + sTxt + ".TGadgets_" +sTxt )
; cc("")
; cc("Structure TMe ; This")
; cc(" RecGadgets.TGadgets_" +sTxt )
; cc("EndStructure")
; cc("")
; cc("Global Me.TMe")
EndProcedure
Procedure PBCode_CreateAllGatgetStructers()
; ======================================================================
; NAME: PBCode_CreateAllGatgetStructers
; DESC: Create PureBasic Code:
; DESC: Steps trough all Tabels and create the Structure with
; DESC: the Gadget Handles
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- STRUCTERS for Gadgets ")
cc(";- ----------------------------------------------------------------------")
ResetList(DBTables())
ForEach DBTables()
PushListPosition(DBTables())
sTxt = DBTables()\Name
PBCode_GadgetStructs(sTxt)
PopListPosition(DBTables())
cc("")
Next
EndProcedure
Procedure PBCode_RecToGadgets(TabName.s, xClear=#False)
; ======================================================================
; NAME: PBCode_RecToGadgets
; DESC: Create PureBasic Code:
; DESC: Steps trough all Tabels and create a Procedure
; DESC: which copies a internal RECORD to the Gadgets
; RET: -
; ======================================================================
; Create PureBasic Code Structure for Editing Gadgets
Protected sTxt.s, sCmd.s, sStr.s
If xClear
ClearList(Code())
EndIf
ResetList(DBTables())
ForEach DBTables()
If DBTables()\Name = TabName
Break
EndIf
Next
sTxt = DBTables()\Name
cc( "; " +sTxt )
ResetList(DBTables()\Fields())
cc("Procedure RecToGadgets_" +sTxt + "(*Rec.TRec_" + sTxt +")" )
; cc("")
cc(" With Gadgets_" + sTxt )
ForEach DBTables()\Fields()
With DBTables()\Fields()
Select \Type
Case #PB_Database_Blob
Case #PB_Database_String
; SetGadgetItemText(\txt_ANBAUORT, 0, *Rec\ANBAUORT)
sStr= " SetGadgetItemText(\txt_" +\Name + ", 0, *Rec\" + \Name +")"
Default
sStr= " SetGadgetItemText(\txt_" +\Name + ", 0, Str(*Rec\" + \Name +"))"
EndSelect
cc(sStr)
EndWith
Next
cc(" EndWith ")
cc("EndProcedure ")
EndProcedure
Procedure PBCode_CreateAllGadgetCode()
; ======================================================================
; NAME: PBCode_CreateAllGadgetCode
; DESC: Create PureBasic Code:
; DESC: All Code Gadgets: Procedures for creating the Gadgets
; DESC: Procedures to copy a RECORD to the Gadgets and back
; RET: -
; ======================================================================
Protected sTxt.s, sCmd.s, sStr.s
ResetList(DBTables())
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- CREATE GADGETS " )
cc(";- ----------------------------------------------------------------------")
ForEach DBTables()
PushListPosition(DBTables())
sTxt = DBTables()\Name
PBCode_Gadgets(sTxt)
PopListPosition(DBTables())
cc("") ; add an empty Line to Code()
Next
ResetList(DBTables())
cc("")
cc(";- ----------------------------------------------------------------------")
cc(";- RECORD TO GADGETS " )
cc(";- ----------------------------------------------------------------------")
ForEach DBTables()
PushListPosition(DBTables())
sTxt = DBTables()\Name
PBCode_RecToGadgets(sTxt)
PopListPosition(DBTables())
cc("")
Next
EndProcedure
DB_Name = "Standard\DB_SQLite\ECAD.db" ; Enter your Database file here
UseSQLiteDatabase() ; Pfad und Dateiname zur SQLite.dll ; "Standard\DB_SQLite\sqlite3.dll"
; hDB = OpenDatabase(#PB_Any, DB_Name, "SYSDBA", "MasterKey", #PB_Database_SQLite)
hDB = OpenDatabase(#PB_Any, DB_Name, "", "", #PB_Database_SQLite) ; bei SQLite keine Benutzerberechtigungen => keine Passworte
Debug hDB
If hdb
Load_DBTables() ; Loads the USER-Table Structures of the DataBase to our List DBTables()
; Here starts the Code creation
PBCode_Structures() ; Creates a Structure for each table
PBCode_CreateAllGatgetStructers()
PBCode_ReadRec() ; Creates a Prodcedure RedRec_[TableName] for each table
PBCode_WriteRec() ; Creates a Prodcedure WriteRec_[TableName] for each tabl
PBCode_ReadWriteProtoypes() ; Creates the Prototype Procedures to Map ReadRec->ReadRec_[TableName], -WirteRec->WriteRec_[TableName]
;PBCode_GadgetStructs("EINZLGER")
;PBCode_Gadgets("EINZLGER", #False)
;PBCode_RecToGadgets("EINZLGER")
PBCode_CreateAllGadgetCode()
CodeToClipboard() ; Copy the generated code to Clipboard
EndIf
DisableExplicit