Code: Select all
;**********************************************************************************************************
; © MicrodevWeb 2015 http://www.microdevweb.com
; Name : SpedDev Module
; Vers : 0.9 started: 2015.09.21 finished :
;**********************************************************************************************************
; 0.8 --> Jointure des table
; ------> SetTableFormOrder(Id_Window,OrderClause$)
; ------> Sélection dans la table sélect par double clique
; 0.9 --> Posibilité d'ajouter une procédure de validation pour un champ
DeclareModule spd
Enumeration Type
#TP_Varchar
#TP_Integer
#TP_Float
#TP_Date
EndEnumeration
Enumeration InupMask
#Mask_None
#Mask_FirstUper
#Mask_AllUper
#Mask_AllLower
#Mask_Number
#Mask_Phone
EndEnumeration
Global gModeNew.b=#True
Declare InitDb(name$,user$="",psw$="")
; Initialise une base de donnée
; name$ --> le nom de la base de donnée
; user$ --> Utilisateur
;psw$ --> Mot de passe utilisateur
Declare AddTable(TableName$)
; Ajout d'une table à la base de donnée
; TableName$ --> le nom de table
Declare AddItem(TableName$,ItemName$,ItemType.i,ItemLen.i=0,repuiered.b=#False,KeyUnique.b=#False)
; Ajout d'un item à la table
;TableName$ --> Table à laquel doit être ajouté l'item
; ItemName$ --> Nom de l'item
; ItemType --> Type de donnée
; ItemLen --> Faclultatif, uniquement pour le type Varchar
; repuiered --> Champs obligatoire ou pas
; KeyUnique --> L'item ne peut pas avoir de doublon
Declare BuildDb(Table$="*",NotExist.b=#True)
; Génére la base de donnée
; Table$ --> La ble à généré ou * pour toutes les tables
; NotExist --> Si vrai Génére la table si elle n'existe pas, si faux génére la table même si elle n'existe pas
Declare AddLink(TableA$,TableB$,B_Requiered.B=#True)
; Ajoute une liaison en 2 fichiers
; TableA$ --> Le nom de la table A créé précedement avec AddTable, la table ne poura contenir q'un record de la table B
; TableB$ --> Le nom de la table B créé précedement avec AddTable, cette table est liée à A et un même record de B peut avoir
; plusieur record de A
; B_Requiered --> Si vrai un record de la table A doit avoir obligatoirement un record de la table B
Declare CreateTableWindow(Id_Window,DbTable$,WindowTitle$,TableWidth,TableHeight,ButtonWidth,ButtonHeight,SheetId,MotherWindow=-1, MaxiMise.b=#False)
; Création d'une fenêtre avec table
; Id_Window --> L'identifiant de la fenêtre qui sera utilisé
; DbTable$ --> La table de la base de donnée qui sera liée
; WindowTitle$ --> Le titre de la fenêtre
; TableWidth --> La largeur de la table
; TableHeight --> La hauteur de la table
; ButtonWidth --> La largeur des boutons
; ButtonHeight --> La hauteur des boutons
; SheetId --> L'identifiant de la fenêtre Fiche
; MotherWindow --> La fenêtre mère ou -1 si pas de fenêtre mère
; MaxiMise --> Si vrai la fenêtre est maximisée
Declare AddColumn(Label$,DbItem$,Width,TableLink$="")
; Ajout de colonne à la table ATTENTION doit être appellé après CreateTableWindow
; Label$ --> Le titre de la colonne
; DbItem$ --> L'item de la table de la base de donnée
; Width --> La largeur de la colonne
; TableLink$ --> La table liée ou vide si pas de liaison
Declare DisplayTableWindow(Id)
; Ouvre la fenêtre table
; Id --> L'identifiant de la fenêtre
Declare CreateSheetWindow(Id_Window,DbTable$,ItemWidth,ItemHeight,NumberColumn,NewTitle$,EditTitle$)
; Création d'une fenêtre de type Fiche
; Id_Window --> L'identifiant de la fenêtre
; DbTable$ --> La table de la base de donnée qui sera liée
; ItemWidth --> La largeur des champs de saisie
; ItemHeight --> La hauteur des champs de saisie (ATTENTION: sera doublé puisque le champs de saisie comporte également le label
; NumberColumn --> Le nombre de colonne de champs si zero ou 1 une colonne de champ
; NewTitle$ --> Le titre de la fenêtre en mode nouveau records
; EditTitle$ --> Le titre de la fenêtre en mode Edition d'un record
Declare AddStringToSheet(Label$,DbItem$,InputMask=spd::#Mask_None,NumberDecimal=0,Ext$="")
; Ajoute une champ string à la fenêtre Fiche ATTENTION doit appelé après CreateSheetWindow
; Label$ --> Le libellé du champ string
; DbItem$ --> L'item de table lié
; InputMask --> Le masque de saisie
; NumberDecimal --> le nombre de décimales si masque de type numérique
; Ext$ un éventuelle exptention si masque
Declare AddComboLinkToSheet(Label$,DbItem$,StrangerDisplay$,buttonSelect.b=#False)
; Ajoute une combo de champ lié à la fenêtre Fiche ATTENTION doit appelé après CreateSheetWindow
; Label$ --> Le libellé du champ string
; DbItem$ --> L'item de table lié
; StrangerDisplay$ --> L'item de la table étrangère qui sera affiché
; buttonSelect --> ajoute un bouton qui permettra l'ouverture de la fenêtre table du fichier lié
Declare DisplaySheetForm(Id_window)
; Ouvre la fenêtre fiche précédement crée
; Id_window --> L'indentifiant de la fenêtre
Declare SetTableFormOrder(Id_Window,OrderClause$)
; Poste un ordre de lecture Sql
; Id_Window --> L'identifiant de la fenêtre
; OrderClause$ --> L'ordre de tri qui doit être comme suit
; ------------------> Nom_table.item 'séparé par des virgules
; -------------------> + ASC ou DESC
;-------------------> ATTENTION Nom_table peut être la table liée
Declare AddValidateProcedure(*CallBackProcedure)
; Ajoute une procédure de validation
; ATTENTION doit être appelé après AddStringToSheet ou AddComboLinkToSheet
; La procedure doit être définie comme suit Procedure(values$)
; Avec AddStringToSheet values$ = à la valueur du champ
; Avec AddComboLinkToSheet values$=Id de la table liée au format String, vous devez donc le convertir en Integer
; ---> Elle doit retourné un booléen #True pour passé le teste ou #False pour arrêter la sauvegarde
EndDeclareModule
Module spd
EnableExplicit
UseSQLiteDatabase()
Declare OpenDb(id)
Declare DbQuery(id,query$)
Declare FildTableWindow()
Declare FildComboLink()
#Margin=10
Prototype.i proValidateProcedure(value$)
Structure item
name$
type.i
myLen.i
requiered.b
KeyUnique.b
EndStructure
Structure table
Map myItem.item()
EndStructure
Structure link
TableA$
TableB$
B_Requiered.b
EndStructure
Structure db
List myLink.link()
Map myTable.table()
name$
user$
psw$
EndStructure
Structure column
name$
item$
LinkTable$
Width.i
EndStructure
Structure tableForm
Id_Window.i
DbTable$
Title$
TableWidth.i
ButtonWidth.i
TableHeight.i
ButtonHeight.i
Maximise.b
NewButtonLabel$
NewButtonId.i
EditButtonLabel$
EditButtonId.i
DeleteButtonLabel$
DeleteButtonId.i
SelectButtonId.i
SelectButtonLabel$
ExitButtonLabel$
ExitButtonId.i
LstIconId.i
TableFont.i
ButtonFont.i
MotherWindow.i
List myColumn.column()
Flag.i
SheetId.i
OrderClause$
EndStructure
Structure ComboLink
id.i
Label$
DbItem$
StrangerDisplay$
ButtonSelect.b
ButtonSelectId.i
EndStructure
Structure sString
id.i
Label$
DbItem$
StrangerItem$
InputMask.i
NumberDecimal.i
Ext$
EndStructure
Structure FormItem
myString.sString
myComboLink.ComboLink
*CallBackProcedure
EndStructure
Structure SheetForm
Id_Window.i
DbTable$
TitleModeNew$
TitleModeEdit$
ItemWith.i
ItemHeight.i
NumberColumn.i
LabelFont.i
ItemFont.i
List myFormItem.FormItem()
BtSubmitLabel$
BtChancelLabel$
BtSubmitId.i
BtChancelId.i
MotherId.i
EndStructure
Structure ana
myDb.db
Map myTableForm.tableForm()
Map mySheetForm.SheetForm()
EndStructure
Global myAna.ana
Global gCurrentLine=-1,gId,gModeSelect.b=#False,gFirstTable
Procedure ListColor(gadget, gridColor=$13458B,BgColorP=$FFFFFF,BgColorI=$008CFF,FgColorP=$000000,FgColorI=$000000)
Protected Nb=CountGadgetItems(gadget),N
If SendMessage_(GadgetID(gadget),#LVM_GETCOUNTPERPAGE,0,0)>Nb
Nb=SendMessage_(GadgetID(gadget),#LVM_GETCOUNTPERPAGE,0,0)
For N=CountGadgetItems(gadget) To Nb-1
AddGadgetItem(gadget,-1,"")
SetGadgetItemData(gadget,CountGadgetItems(gadget)-1,-1)
Next
EndIf
SetGadgetColor(gadget,#PB_Gadget_LineColor,gridColor)
For N=1 To Nb
If N & 1
SetGadgetItemColor(gadget,N-1,#PB_Gadget_BackColor,BgColorI)
SetGadgetItemColor(gadget,N-1,#PB_Gadget_FrontColor,FgColorI)
Else
SetGadgetItemColor(gadget,N-1,#PB_Gadget_BackColor,BgColorP)
SetGadgetItemColor(gadget,N-1,#PB_Gadget_FrontColor,FgColorP)
EndIf
Next
EndProcedure
Procedure NoEmpty()
Protected G=EventGadget()
Protected N=GetGadgetState(G)
If GetGadgetItemData(G,N)=-1
SetGadgetState(G,-1)
EndIf
EndProcedure
Procedure InitDb(name$,user$="",psw$="")
With myAna\myDb
\name$=name$
\psw$=psw$
\user$=user$
EndWith
EndProcedure
Procedure AddTable(TableName$)
With myAna\myDb
If FindMapElement(\myTable(),TableName$)<>0
MessageRequester("AddTable","Error this table "+TableName$+" already exit...")
ProcedureReturn #False
EndIf
AddMapElement(\myTable(),TableName$)
ProcedureReturn #True
EndWith
EndProcedure
Procedure AddItem(TableName$,ItemName$,ItemType.i,ItemLen.i=0,repuiered.b=#False,KeyUnique.b=#False)
With myAna\myDb
If FindMapElement(\myTable(),TableName$)=0
MessageRequester("AddItem","Error this table "+TableName$+" not exit...")
ProcedureReturn #False
EndIf
If FindMapElement(\myTable()\myItem(),ItemName$)<>0
MessageRequester("AddItem","Error this item "+ItemName$+" already exit...")
ProcedureReturn #False
EndIf
If ItemType<#TP_Varchar Or ItemType>#TP_Date
MessageRequester("AddItem","Bad Type item")
ProcedureReturn #False
EndIf
AddMapElement(\myTable()\myItem(),ItemName$)
\myTable()\myItem()\name$=ItemName$
\myTable()\myItem()\type=ItemType
\myTable()\myItem()\requiered=repuiered
\myTable()\myItem()\myLen=ItemLen
\myTable()\myItem()\KeyUnique=KeyUnique
ProcedureReturn #True
EndWith
EndProcedure
Procedure MakeTable(NotExist)
Protected query$,id,N
With myAna\myDb
id=OpenDatabase(#PB_Any,\name$,\user$,\psw$)
If id=0
MessageRequester("MakeTable Error","I cant open this database")
ProcedureReturn #False
EndIf
EndWith
ForEach myAna\myDb\myTable()
With myAna\myDb\myTable()
query$="CREATE TABLE "
If NotExist
query$+" IF NOT EXISTS "
EndIf
query$+MapKey(myAna\myDb\myTable())
query$+"(id INTEGER PRIMARY KEY AUTOINCREMENT,"
N=0
; Recherche de tous les items
ForEach \myItem()
N+1
query$+\myItem()\name$+" "
Select \myItem()\type
Case #TP_Varchar
query$+"VARCHAR("+Str(\myItem()\myLen)+")"
Case #TP_Integer
query$+"INTEGER"
Case #TP_Float
query$+"FLOAT"
Case #TP_Date
query$+"DATE"
EndSelect
If N<MapSize(\myItem())
query$+","
EndIf
Next
query$+")"
EndWith
If DatabaseUpdate(id,query$)=0
MessageRequester("MakeTable Error",DatabaseError())
ProcedureReturn #False
EndIf
Next
CloseDatabase(id)
EndProcedure
Procedure BuildDb(File$="*",NotExist.b=#True)
Protected idFile
; 1) Création du fichier si il n'existe pas
With myAna\myDb
If FileSize(\name$)=-1
idFile=CreateFile(#PB_Any,\name$)
If idFile=0
MessageRequester("MakeDb Error","Cant create file "+\name$)
ProcedureReturn #False
EndIf
CloseFile(idFile)
EndIf
If File$="*"
ForEach \myTable()
If Not MakeTable(NotExist)
ProcedureReturn #False
EndIf
Next
Else
If FindMapElement(\myTable(),File$)=0
MessageRequester("MakeDb Error","This table "+File$+" not exist")
ProcedureReturn #False
EndIf
If Not MakeTable(NotExist)
ProcedureReturn #False
EndIf
EndIf
ProcedureReturn #True
EndWith
EndProcedure
Procedure AddLink(TableA$,TableB$,B_Requiered.B=#True)
;Vérifie l'existence des tables
With myAna\myDb
If FindMapElement(\myTable(),TableA$)=0
MessageRequester("AddLink Error","The Tabel A$ "+TableA$+" not exist")
ProcedureReturn #False
EndIf
AddMapElement(\myTable()\myItem(),"id_"+TableB$)
\myTable()\myItem()\requiered=B_Requiered
\myTable()\myItem()\name$="id_"+TableB$
\myTable()\myItem()\type=spd::#TP_Integer
If FindMapElement(\myTable(),TableB$)=0
MessageRequester("AddLink Error","The Tabel B$ "+TableB$+" not exist")
ProcedureReturn #False
EndIf
AddElement(\myLink())
\myLink()\TableA$=TableA$
\myLink()\TableB$=TableB$
\myLink()\B_Requiered=B_Requiered
ProcedureReturn #True
EndWith
EndProcedure
Procedure EventSelectLineTable(Nline.i)
gCurrentLine=Nline
EndProcedure
Procedure CreateTableWindow(Id_Window,DbTable$,WindowTitle$,TableWidth,TableHeight,ButtonWidth,ButtonHeight,SheetId,MotherWindow=-1, MaxiMise.b=#False)
If FindMapElement(myAna\myTableForm(),Str(Id_Window))<>0
MessageRequester("CreateTableWindow Error","This TableWindow "+Str(Id_Window)+" already exist")
ProcedureReturn #False
EndIf
If FindMapElement(myAna\myDb\myTable(),DbTable$)=0
MessageRequester("CreateTableWindow Error","This DbTable "+DbTable$+" not exist")
ProcedureReturn #False
EndIf
AddMapElement(myAna\myTableForm(),Str(Id_Window))
With myAna\myTableForm()
\Id_Window=Id_Window
\TableWidth=TableWidth
\ButtonWidth=ButtonWidth
\Title$=WindowTitle$
\DbTable$=DbTable$
\NewButtonLabel$="Nouveau"
\EditButtonLabel$="Editer"
\DeleteButtonLabel$="Supprimer"
\ExitButtonLabel$="Quitter"
\TableHeight=TableHeight
\ButtonHeight=ButtonHeight
\Maximise=MaxiMise
\ButtonFont=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality)
\TableFont=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality)
\MotherWindow=MotherWindow
\Flag=#PB_Window_SystemMenu|#PB_Window_ScreenCentered
\SheetId=SheetId
\SelectButtonLabel$="Sélectionner"
If MaxiMise
\Flag|#PB_Window_Maximize
EndIf
EndWith
EndProcedure
Procedure AddColumn(Label$,DbItem$,Width,TableLink$="")
With myAna\myTableForm()
AddElement(\myColumn())
\myColumn()\item$=DbItem$
\myColumn()\name$=Label$
\myColumn()\LinkTable$=TableLink$
\myColumn()\Width=Width
EndWith
EndProcedure
Procedure CloseTableWindow()
With myAna\myTableForm()
If \MotherWindow<>-1
DisableWindow(\MotherWindow,#False)
EndIf
CloseWindow(\Id_Window)
If gModeSelect
PopMapPosition(myAna\myTableForm())
gModeSelect=#False
EndIf
EndWith
EndProcedure
Procedure NewTableWindow()
; Passe en mode nouveau record
spd::gModeNew=#True
With myAna\myTableForm()
DisplaySheetForm(\SheetId)
EndWith
EndProcedure
Procedure EditTableWindow()
Protected query$,N,R
With myAna\myTableForm()
If GetGadgetState(\LstIconId)=-1
MessageRequester(\Title$,"Vous n'avez pas sélectionner d'élément dans la liste...")
ProcedureReturn
EndIf
FindMapElement(myAna\myDb\myTable(),\DbTable$)
query$="SELECT id,"
; Passe en mode edition de record
spd::gModeNew=#False
DisplaySheetForm(\SheetId)
ForEach myAna\mySheetForm()\myFormItem()
N+1
If myAna\mySheetForm()\myFormItem()\myString\DbItem$<>""
query$+myAna\mySheetForm()\myFormItem()\myString\DbItem$
EndIf
If myAna\mySheetForm()\myFormItem()\myComboLink\DbItem$<>""
query$+myAna\mySheetForm()\myFormItem()\myComboLink\DbItem$
EndIf
If N<ListSize(myAna\mySheetForm()\myFormItem())
query$+","
EndIf
Next
gId=GetGadgetItemData(\LstIconId,GetGadgetState(\LstIconId))
query$+" FROM "+\DbTable$+" WHERE id="+gId
OpenDb(0)
If Not DbQuery(0, query$)
ProcedureReturn
EndIf
FirstDatabaseRow(0)
N=0
ForEach myAna\mySheetForm()\myFormItem()
N+1
If myAna\mySheetForm()\myFormItem()\myString\DbItem$<>""
FindMapElement(myAna\myDb\myTable()\myItem(),myAna\mySheetForm()\myFormItem()\myString\DbItem$)
Select myAna\myDb\myTable()\myItem()\type
Case spd::#TP_Integer
SetGadgetText(myAna\mySheetForm()\myFormItem()\myString\id,Str(GetDatabaseLong(0,N)))
Case spd::#TP_Float
SetGadgetText(myAna\mySheetForm()\myFormItem()\myString\id,StrF(GetDatabaseFloat(0,N)))
Case spd::#TP_Varchar
SetGadgetText(myAna\mySheetForm()\myFormItem()\myString\id,GetDatabaseString(0,N))
EndSelect
EndIf
If myAna\mySheetForm()\myFormItem()\myComboLink\DbItem$<>""
For R=1 To CountGadgetItems(myAna\mySheetForm()\myFormItem()\myComboLink\id)
If GetGadgetItemData(myAna\mySheetForm()\myFormItem()\myComboLink\id,R)=GetDatabaseLong(0,N)
SetGadgetState(myAna\mySheetForm()\myFormItem()\myComboLink\id,R)
Break
EndIf
Next
EndIf
Next
CloseDatabase(#PB_All)
EndWith
EndProcedure
Procedure DeleteTableWindow()
Protected query$
With myAna\myTableForm()
If GetGadgetState(\LstIconId)=-1
MessageRequester(\Title$,"Vous n'avez pas sélectionner d'élément dans la liste...")
ProcedureReturn
EndIf
; Recherche erreur d'intégrité
OpenDb(0)
ForEach myAna\myDb\myLink()
If myAna\myDb\myLink()\TableB$=\DbTable$
If myAna\myDb\myLink()\B_Requiered
query$="SELECT * FROM "+myAna\myDb\myLink()\TableA$
query$+" WHERE id_"+ myAna\myDb\myLink()\TableB$+"="+Str(GetGadgetItemData(\LstIconId,GetGadgetState(\LstIconId)))
If Not DbQuery(0,query$)
ProcedureReturn
EndIf
If FirstDatabaseRow(0)
CloseDatabase(0)
MessageRequester("Erreur d'intégrité","Vous ne pouvez pas supprimer cet élément car il est utilisé dans un autre fichier...")
ProcedureReturn
EndIf
EndIf
EndIf
Next
If MessageRequester("Suppression d'un élément","Etes-vous certaint de vouloir supprimer cet élémént?",#PB_MessageRequester_YesNo)=#PB_MessageRequester_No
CloseDatabase(0)
ProcedureReturn
EndIf
query$="DELETE FROM "+\DbTable$+" WHERE id="+Str(GetGadgetItemData(\LstIconId,GetGadgetState(\LstIconId)))
If DatabaseUpdate(0,query$)=0
MessageRequester("DataBase Error",DatabaseError())
CloseDatabase(0)
ProcedureReturn
EndIf
CloseDatabase(0)
FildTableWindow()
EndWith
EndProcedure
Procedure OpenDb(id)
If OpenDatabase(id,myAna\myDb\name$,myAna\myDb\user$,myAna\myDb\psw$)=0
MessageRequester("DataBase Error","I cant open Database...")
ProcedureReturn #False
EndIf
ProcedureReturn #True
EndProcedure
Procedure DbQuery(id,query$)
If DatabaseQuery(id,query$)=0
MessageRequester("DataBase Error",DatabaseError())
ProcedureReturn #False
EndIf
ProcedureReturn #True
EndProcedure
Procedure FildTableWindow()
Protected query$,value$,N,txt$
Protected NewList TableLink$()
Protected WhereClause$
With myAna\myTableForm()
query$="SELECT "+\DbTable$+".id,"
ClearGadgetItems(myAna\myTableForm()\LstIconId)
ForEach \myColumn()
; Si pas de liaison
If \myColumn()\LinkTable$=""
query$+\DbTable$+"."+\myColumn()\item$
Else
; Mémorise la table étrangère liée
AddElement(TableLink$())
TableLink$()=StringField(\myColumn()\item$,2,"_")
query$+TableLink$()+"."+\myColumn()\LinkTable$
EndIf
N+1
If N<ListSize(\myColumn())
query$+","
EndIf
Next
query$+" FROM "+\DbTable$
WhereClause$=""
; Si il y a des tables liées
N=0
ForEach TableLink$()
query$+","+TableLink$()
If WhereClause$=""
WhereClause$=" WHERE "+TableLink$()+".id="+\DbTable$+".id_"+TableLink$()
Else
WhereClause$+","+TableLink$()+".id="+\DbTable$+".id_"+TableLink$()
EndIf
Next
query$+WhereClause$
If \OrderClause$<>""
query$+" ORDER BY "+\OrderClause$
EndIf
If Not OpenDb(0):ProcedureReturn #False: EndIf
If Not DbQuery(0,query$):ProcedureReturn #False:EndIf
While NextDatabaseRow(0)
N=0
value$=""
ForEach \myColumn()
N+1
; Si pas de liaison
If \myColumn()\LinkTable$=""
If FindMapElement(myAna\myDb\myTable(),\DbTable$)=0
MessageRequester("FildTableWindow Error","This DbTable "+\DbTable$+" not exist")
ProcedureReturn #False
EndIf
If FindMapElement(myAna\myDb\myTable()\myItem(),\myColumn()\item$)=0
MessageRequester("FildTableWindow Error","This Item "+\myColumn()\item$+" not exist")
ProcedureReturn #False
EndIf
Else
If FindMapElement(myAna\myDb\myTable(),StringField(\myColumn()\item$,2,"_"))=0
MessageRequester("FildTableWindow Error","This DbTable "+StringField(\myColumn()\item$,2,"_")+" not exist")
ProcedureReturn #False
EndIf
If FindMapElement(myAna\myDb\myTable()\myItem(),\myColumn()\LinkTable$)=0
MessageRequester("FildTableWindow Error","This Item "+\myColumn()\LinkTable$+" not exist")
ProcedureReturn #False
EndIf
EndIf
Select myAna\myDb\myTable()\myItem()\type
Case #TP_Varchar
value$+GetDatabaseString(0,N)
Case #TP_Integer
value$+Str(GetDatabaseLong(0,N))
Case #TP_Float
value$+StrF(GetDatabaseFloat(0,N))
Case #TP_Date
value$+Str(GetDatabaseLong(0,N))
EndSelect
If N<ListSize(\myColumn())
value$+Chr(10)
EndIf
Next
AddGadgetItem(myAna\myTableForm()\LstIconId,-1,value$)
SetGadgetItemData(myAna\myTableForm()\LstIconId,CountGadgetItems(myAna\myTableForm()\LstIconId)-1,GetDatabaseLong(0,0))
Wend
ListColor(\LstIconId)
CloseDatabase(#PB_All)
EndWith
EndProcedure
Procedure OpenSheetLinkSelect()
gModeSelect=#True
Protected id
id=GetActiveGadget()
PushMapPosition(myAna\myTableForm())
PushMapPosition(myAna\mySheetForm())
ForEach myAna\mySheetForm()\myFormItem()
With myAna\mySheetForm()\myFormItem()\myComboLink
If \id=id
Break
EndIf
Protected tb$=StringField(\DbItem$,2,"_")
ForEach myAna\myTableForm()
If myAna\myTableForm()\DbTable$=tb$
DisplayTableWindow(myAna\myTableForm()\Id_Window)
Break 2
EndIf
Next
EndWith
Next
EndProcedure
Procedure SelectFromTable()
Protected N,id
With myAna\myTableForm()
If GetGadgetState(\LstIconId)=-1
MessageRequester("Sélection d'un élément","Vous n'avez sélectionné aucun élément dans la liste.")
ProcedureReturn
EndIf
FildComboLink()
id=myAna\mySheetForm()\myFormItem()\myComboLink\id
For N=0 To CountGadgetItems(id)-1
If GetGadgetItemData(id,N)=GetGadgetItemData(\LstIconId,GetGadgetState(\LstIconId))
SetGadgetState(id,N)
Break
EndIf
Next
CloseTableWindow()
EndWith
EndProcedure
Procedure DisplayTableWindow(Id)
If FindMapElement(myAna\myTableForm(),Str(Id))=0
MessageRequester("DisplayTableWindow Error","This TableWindow "+Str(Id)+" not exist")
ProcedureReturn #False
EndIf
With myAna\myTableForm()
Protected WF,HF
WF=(\TableWidth+\ButtonWidth)+(#Margin * 3)
HF=\TableHeight+(#Margin * 2)
If \MotherWindow=-1
OpenWindow(\Id_Window,0,0,WF,HF,\Title$,\Flag)
Else
DisableWindow(\MotherWindow,#True)
OpenWindow(\Id_Window,0,0,WF,HF,\Title$,\Flag,WindowID(\MotherWindow))
EndIf
BindEvent(#PB_Event_CloseWindow,@CloseTableWindow(),\Id_Window)
; Mise en place de la Table
\LstIconId=ListIconGadget(#PB_Any,#Margin,#Margin,\TableWidth,\TableHeight,"",0,#PB_ListIcon_AlwaysShowSelection|#PB_ListIcon_GridLines|#PB_ListIcon_FullRowSelect)
; Mise en place des colonnes
Protected N
ForEach \myColumn()
AddGadgetColumn(\LstIconId,N,\myColumn()\name$,\myColumn()\Width)
N+1
Next
; Police de la table
SetGadgetFont(\LstIconId,FontID(\TableFont))
; Mise en place des boutons
Protected X=(#Margin * 2)+\TableWidth
Protected Y=#Margin
\NewButtonId=ButtonGadget(#PB_Any,X,Y,\ButtonWidth,\ButtonHeight,\NewButtonLabel$)
SetGadgetFont(\NewButtonId,FontID(\ButtonFont))
Y+#Margin+\ButtonHeight
\EditButtonId=ButtonGadget(#PB_Any,X,Y,\ButtonWidth,\ButtonHeight,\EditButtonLabel$)
SetGadgetFont(\EditButtonId,FontID(\ButtonFont))
Y+#Margin+\ButtonHeight
\DeleteButtonId=ButtonGadget(#PB_Any,X,Y,\ButtonWidth,\ButtonHeight,\DeleteButtonLabel$)
SetGadgetFont(\DeleteButtonId,FontID(\ButtonFont))
If gModeSelect
Y+#Margin+\ButtonHeight
\SelectButtonId=ButtonGadget(#PB_Any,X,Y,\ButtonWidth,\ButtonHeight,\SelectButtonLabel$)
SetGadgetFont(\SelectButtonId,FontID(\ButtonFont))
EndIf
Y+#Margin+(\ButtonHeight*2)
\ExitButtonId=ButtonGadget(#PB_Any,X,Y,\ButtonWidth,\ButtonHeight,\ExitButtonLabel$)
SetGadgetFont(\ExitButtonId,FontID(\ButtonFont))
BindGadgetEvent(\ExitButtonId,@CloseTableWindow())
BindGadgetEvent(\NewButtonId,@NewTableWindow())
BindGadgetEvent(\EditButtonId,@EditTableWindow())
BindGadgetEvent(\DeleteButtonId,@DeleteTableWindow())
If gModeSelect
BindGadgetEvent(\SelectButtonId,@SelectFromTable())
BindGadgetEvent(\LstIconId,@SelectFromTable(),#PB_EventType_LeftDoubleClick)
EndIf
BindGadgetEvent(\LstIconId,@NoEmpty())
FildTableWindow()
EndWith
EndProcedure
Procedure CreateSheetWindow(Id_Window,DbTable$,ItemWidth,ItemHeight,NumberColumn,NewTitle$,EditTitle$)
If FindMapElement(myAna\mySheetForm(),Str(Id_Window))<>0
MessageRequester("CreateSheetWindow Error","This window Id "+Str(Id_Window)+" already exist...")
ProcedureReturn #False
EndIf
AddMapElement(myAna\mySheetForm(),Str(Id_Window))
With myAna\mySheetForm()
\Id_Window=Id_Window
\DbTable$=DbTable$
\ItemHeight=ItemHeight
\ItemWith=ItemWidth
\NumberColumn=NumberColumn
\TitleModeNew$=NewTitle$
\TitleModeEdit$=EditTitle$
\LabelFont=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality)
\ItemFont=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality)
\BtChancelLabel$="Annuler"
\BtSubmitLabel$="Valider"
EndWith
EndProcedure
Procedure AddStringToSheet(Label$,DbItem$,InputMask=spd::#Mask_None,NumberDecimal=0,Ext$="")
AddElement(myAna\mySheetForm()\myFormItem())
myAna\mySheetForm()\myFormItem()\CallBackProcedure=-1
With myAna\mySheetForm()\myFormItem()\myString
\DbItem$=DbItem$
\Label$=Label$
\InputMask=InputMask
\NumberDecimal=NumberDecimal
\Ext$=Ext$
EndWith
EndProcedure
Procedure CloseSheetForm()
With myAna\mySheetForm()
DisableWindow(\MotherId,#False)
CloseWindow(\Id_Window)
If gModeSelect
PopMapPosition(myAna\mySheetForm())
EndIf
EndWith
EndProcedure
Procedure MaskingString(Gadget,mask,NbDecimal=0,Ext$="")
Protected txt$,PosStart.i,PosEnd.i,N,Car$
Protected number$="0123456789"
Protected phone$="0123456789-/\:. "
Protected Dec=-1
If EventType()=#PB_EventType_Change
SendMessage_(GadgetID(Gadget),#EM_GETSEL,@PosStart,@PosEnd)
Select mask
Case 1 ;Première lettre en majuscule
txt$=UCase(Left(GetGadgetText(Gadget),1))+Right(GetGadgetText(Gadget),Len(GetGadgetText(Gadget))-1)
Case 2 ;Tout en majuscule
txt$=UCase(GetGadgetText(Gadget))
Case 3 ;Tout en miniscule
txt$=LCase(GetGadgetText(Gadget))
Case 4 ;Numérique
For N=1 To Len(GetGadgetText(Gadget))
Car$=Mid(GetGadgetText(Gadget),N,1)
If FindString(number$,Car$)<>0
If Dec=-1
txt$+Car$
Else
If Dec<NbDecimal
txt$+Car$
Dec+1
EndIf
EndIf
EndIf
If NbDecimal>0
If Car$="." And Dec=-1
txt$+"."
Dec=0
EndIf
EndIf
Next
Case 5 ;Phone
For N=1 To Len(GetGadgetText(Gadget))
Car$=Mid(GetGadgetText(Gadget),N,1)
If FindString(phone$,Car$)<>0
txt$+Car$
EndIf
Next
EndSelect
If Ext$<>""
txt$+Ext$
EndIf
SetGadgetText(Gadget,txt$)
SendMessage_(GadgetID(Gadget),#EM_SETSEL,PosStart,PosEnd)
EndIf
EndProcedure
Procedure EventMask()
Protected id=GetActiveGadget()
; Recherche l'item
ForEach myAna\mySheetForm()\myFormItem()
With myAna\mySheetForm()\myFormItem()
If \myString\id=id
MaskingString(id,\myString\InputMask,\myString\NumberDecimal,\myString\Ext$)
EndIf
EndWith
Next
EndProcedure
Procedure InputRequiered(DbTable$,DbItem$)
If FindMapElement(myAna\myDb\myTable(),DbTable$)=0
MessageRequester("InputRequiered Error","This Table "+DbTable$+" not exist...")
ProcedureReturn #False
EndIf
If FindMapElement(myAna\myDb\myTable()\myItem(),DbItem$)=0
MessageRequester("InputRequiered Error","This Item "+DbItem$+" not exist...")
ProcedureReturn #False
EndIf
If myAna\myDb\myTable()\myItem()\requiered
ProcedureReturn #True
EndIf
ProcedureReturn #False
EndProcedure
Procedure InputUnique(DbTable$,DbItem$,Values$)
Protected query$
FindMapElement(myAna\myDb\myTable(),DbTable$)
FindMapElement(myAna\myDb\myTable()\myItem(),DbItem$)
If myAna\myDb\myTable()\myItem()\KeyUnique
query$="SELECT * FROM "+DbTable$+" WHERE "+DbItem$+"="
Select myAna\myDb\myTable()\myItem()\type
Case spd::#TP_Varchar
query$+"'"+Values$+"'"
Case spd::#TP_Integer,spd::#TP_Float
query$+Values$
EndSelect
If spd::gModeNew=#False
query$+" AND id !="+Str(gid)
EndIf
OpenDb(0)
If Not DbQuery(0,query$)
CloseDatabase(#PB_All)
ProcedureReturn #True
EndIf
If FirstDatabaseRow(0)
CloseDatabase(#PB_All)
ProcedureReturn #True
EndIf
EndIf
CloseDatabase(#PB_All)
ProcedureReturn #False
EndProcedure
Procedure SaveSheetForm()
Protected query$,set$,value$,N,mod$
Protected ValidateProcedure
With myAna\mySheetForm()
FindMapElement(myAna\myDb\myTable(),\DbTable$)
ForEach \myFormItem()
N+1
If \myFormItem()\myString\DbItem$<>""
SetGadgetColor(\myFormItem()\myString\id,#PB_Gadget_BackColor,$FFFFFF)
If InputRequiered(\DbTable$,\myFormItem()\myString\DbItem$)
If Len(GetGadgetText(\myFormItem()\myString\id))=0
SetActiveGadget(\myFormItem()\myString\id)
SetGadgetColor(\myFormItem()\myString\id,#PB_Gadget_BackColor,$8080F0)
ProcedureReturn
EndIf
EndIf
If InputUnique(\DbTable$,\myFormItem()\myString\DbItem$,GetGadgetText(\myFormItem()\myString\id))
SetActiveGadget(\myFormItem()\myString\id)
SetGadgetColor(\myFormItem()\myString\id,#PB_Gadget_BackColor,$8080F0)
MessageRequester("Erreur de doublon","Il existe un doublon pour ce champ")
ProcedureReturn
EndIf
If \myFormItem()\CallBackProcedure<>-1
ValidateProcedure.proValidateProcedure=\myFormItem()\CallBackProcedure
If Not ValidateProcedure(GetGadgetText(\myFormItem()\myString\id))
ProcedureReturn
EndIf
EndIf
FindMapElement(myAna\myDb\myTable()\myItem(),\myFormItem()\myString\DbItem$)
set$+\myFormItem()\myString\DbItem$
mod$+\myFormItem()\myString\DbItem$+"="
Select myAna\myDb\myTable()\myItem()\type
Case spd::#TP_Varchar
value$+"'"+GetGadgetText(\myFormItem()\myString\id)+"'"
mod$+"'"+GetGadgetText(\myFormItem()\myString\id)+"'"
Case spd::#TP_Integer,spd::#TP_Float
value$+GetGadgetText(\myFormItem()\myString\id)
mod$+GetGadgetText(\myFormItem()\myString\id)
EndSelect
EndIf
If \myFormItem()\myComboLink\DbItem$<>""
SetGadgetColor(\myFormItem()\myComboLink\id,#PB_Gadget_BackColor,$FFFFFF)
FindMapElement(myAna\myDb\myTable()\myItem(),\myFormItem()\myComboLink\DbItem$)
If myAna\myDb\myTable()\myItem()\requiered
If GetGadgetState(\myFormItem()\myComboLink\id)=0
SetGadgetColor(\myFormItem()\myComboLink\id,#PB_Gadget_BackColor,$8080F0)
SetActiveGadget(\myFormItem()\myComboLink\id)
ProcedureReturn
EndIf
EndIf
Protected mData
mData=GetGadgetItemData(\myFormItem()\myComboLink\id,GetGadgetState(\myFormItem()\myComboLink\id))
If \myFormItem()\CallBackProcedure<>-1
ValidateProcedure.proValidateProcedure=\myFormItem()\CallBackProcedure
If Not ValidateProcedure(Str(mData))
ProcedureReturn
EndIf
EndIf
set$+\myFormItem()\myComboLink\DbItem$
mod$+\myFormItem()\myComboLink\DbItem$+"="+Str(mData)
value$+Str(mData)
EndIf
If N<ListSize(\myFormItem())
set$+","
value$+","
mod$+","
EndIf
Next
If spd::gModeNew
query$="INSERT INTO "+\DbTable$+"("+set$+") VALUES ("+value$+")"
Else
query$="UPDATE "+\DbTable$+" SET "+mod$+" WHERE id="+Str(gId)
EndIf
OpenDb(0)
If DatabaseUpdate(0,query$)=0
MessageRequester("DataBase Error",DatabaseError())
ProcedureReturn #False
EndIf
CloseDatabase(#PB_All)
FildTableWindow()
CloseSheetForm()
EndWith
EndProcedure
Procedure FildComboLink()
Protected tb$=StringField(myAna\mySheetForm()\myFormItem()\myComboLink\DbItem$,2,"_")
Protected query$="SELECT id,"+myAna\mySheetForm()\myFormItem()\myComboLink\StrangerDisplay$
query$+" FROM "+tb$+" ORDER BY "+myAna\mySheetForm()\myFormItem()\myComboLink\StrangerDisplay$
OpenDb(0)
If Not DbQuery(0,query$)
CloseDatabase(0)
ProcedureReturn
EndIf
ClearGadgetItems(myAna\mySheetForm()\myFormItem()\myComboLink\id)
AddGadgetItem(myAna\mySheetForm()\myFormItem()\myComboLink\id,-1,"------")
SetGadgetItemData(myAna\mySheetForm()\myFormItem()\myComboLink\id,CountGadgetItems(myAna\mySheetForm()\myFormItem()\myComboLink\id)-1,-1)
While NextDatabaseRow(0)
AddGadgetItem(myAna\mySheetForm()\myFormItem()\myComboLink\id,-1,GetDatabaseString(0,1))
SetGadgetItemData(myAna\mySheetForm()\myFormItem()\myComboLink\id,CountGadgetItems(myAna\mySheetForm()\myFormItem()\myComboLink\id)-1,GetDatabaseLong(0,0))
Wend
SetGadgetState(myAna\mySheetForm()\myFormItem()\myComboLink\id,0)
CloseDatabase(#PB_All)
EndProcedure
Procedure DisplaySheetForm(Id_window)
If FindMapElement(myAna\mySheetForm(),Str(Id_window))=0
MessageRequester("DisplaySheetForm Error","This window "+Str(Id_window)+" not exist...")
EndIf
With myAna\mySheetForm()
Protected WF=\ItemWith * \NumberColumn +(#Margin * 2)
WF+#Margin * (\NumberColumn-1)
; Les champ string avec leurs libellé
Protected HF=ListSize(\myFormItem()) * (\ItemHeight * 2)
; La marge en chaque champ string
HF+ListSize(\myFormItem()) * #Margin
; les bouton Submit et chancel
HF+\ItemHeight+(#Margin*2)
Protected title$
Select gModeNew
Case #True
title$=\TitleModeNew$
Case #False
title$=\TitleModeEdit$
EndSelect
Protected flag=#PB_Window_ScreenCentered|#PB_Window_SystemMenu
\MotherId=GetActiveWindow()
DisableWindow(\MotherId,#True)
OpenWindow(\Id_Window,0,0,WF,HF,title$,flag,WindowID(\MotherId))
BindEvent(#PB_Event_CloseWindow,@CloseSheetForm(),\Id_Window)
Protected X=#Margin
Protected Y=#Margin
Protected tmp
Protected CurrentColumn=1
Protected label$,N
ForEach \myFormItem()
N+1
; Un champ string
If \myFormItem()\myString\DbItem$<>""
label$=\myFormItem()\myString\Label$
; Regarde si le champ est requis
If InputRequiered(\DbTable$,\myFormItem()\myString\DbItem$)
label$+" (*)"
EndIf
tmp=TextGadget(#PB_Any,X,Y,\ItemWith,\ItemHeight,label$)
SetGadgetFont(tmp,FontID(\ItemFont))
Y+\ItemHeight
\myFormItem()\myString\id=StringGadget(#PB_Any,X,Y,\ItemWith,\ItemHeight,"")
; Place une limite de saisie si varchar
FindMapElement(myAna\myDb\myTable(),\DbTable$)
FindMapElement(myAna\myDb\myTable()\myItem(),\myFormItem()\myString\DbItem$)
Select myAna\myDb\myTable()\myItem()\type
Case spd::#TP_Varchar
SetGadgetAttribute( \myFormItem()\myString\id,#PB_String_MaximumLength,myAna\myDb\myTable()\myItem()\myLen)
EndSelect
SetGadgetFont(\myFormItem()\myString\id,FontID(\ItemFont))
; Si un masque place le callback
If \myFormItem()\myString\InputMask<>spd::#Mask_None
BindGadgetEvent(\myFormItem()\myString\id,@EventMask())
EndIf
EndIf
; Un combo link
If \myFormItem()\myComboLink\DbItem$<>""
label$=\myFormItem()\myComboLink\Label$
If InputRequiered(\DbTable$,\myFormItem()\myComboLink\DbItem$)
label$+" (*)"
EndIf
tmp=TextGadget(#PB_Any,X,Y,\ItemWith,\ItemHeight,label$)
SetGadgetFont(tmp,FontID(\ItemFont))
Y+\ItemHeight
Protected WCB
If \myFormItem()\myComboLink\ButtonSelect
WCB=\ItemWith-(30+#Margin)
\myFormItem()\myComboLink\ButtonSelectId=ButtonGadget(#PB_Any,X+#Margin+WCB,Y,30,\ItemHeight,"...")
BindGadgetEvent(\myFormItem()\myComboLink\ButtonSelectId,@OpenSheetLinkSelect())
Else
WCB=\ItemWith
EndIf
\myFormItem()\myComboLink\id=ComboBoxGadget(#PB_Any,X,Y,WCB,\ItemHeight)
SetGadgetFont(\myFormItem()\myComboLink\id,FontID(\ItemFont))
FildComboLink()
EndIf
If N<ListSize(\myFormItem())
; Passe à la colonne suivante
CurrentColumn+1
If CurrentColumn>\NumberColumn
CurrentColumn=\NumberColumn
; Passe à la ligne suivante
Y+\ItemHeight+#Margin
EndIf
X=(\ItemWith *(CurrentColumn-1))+#Margin
EndIf
Next
; Ajout des boutons
X=#Margin
Y+\ItemHeight+#Margin
Protected W=(WindowWidth(\Id_Window,#PB_Window_InnerCoordinate)-(#Margin*3))/2
\BtSubmitId=ButtonGadget(#PB_Any,X,Y,W,\ItemHeight,\BtSubmitLabel$)
X+W+#Margin
\BtChancelId=ButtonGadget(#PB_Any,X,Y,W,\ItemHeight,\BtChancelLabel$)
BindGadgetEvent(\BtChancelId,@CloseSheetForm())
BindGadgetEvent(\BtSubmitId,@SaveSheetForm())
EndWith
EndProcedure
Procedure AddComboLinkToSheet(Label$,DbItem$,StrangerDisplay$,buttonSelect.b=#False)
With myAna\mySheetForm()
AddElement(myAna\mySheetForm()\myFormItem())
myAna\mySheetForm()\myFormItem()\CallBackProcedure=-1
\myFormItem()\myComboLink\Label$=Label$
\myFormItem()\myComboLink\DbItem$=DbItem$
\myFormItem()\myComboLink\StrangerDisplay$=StrangerDisplay$
\myFormItem()\myComboLink\ButtonSelect=buttonSelect
EndWith
EndProcedure
Procedure SetTableFormOrder(Id_Window,OrderClause$)
If FindMapElement(myAna\myTableForm(),Str(Id_Window))=0
MessageRequester("SetTableFormOrder Error","This Table window "+Str(Id_Window)+" not exist")
EndIf
myAna\myTableForm()\OrderClause$=OrderClause$
EndProcedure
Procedure AddValidateProcedure(*CallBackProcedure)
With myAna\mySheetForm()\myFormItem()
\CallBackProcedure=*CallBackProcedure
EndWith
EndProcedure
EndModule
Dowload the launcher HERE
