Base de données avec Json

Partagez votre expérience de PureBasic avec les autres utilisateurs.
Répondre
Avatar de l’utilisateur
microdevweb
Messages : 1802
Inscription : mer. 29/juin/2011 14:11
Localisation : Belgique

Base de données avec Json

Message par microdevweb »

Voici un petit exemple de base de données avec Json, l’exemple reprend des contacts avec un liaison à une localité. J'attire votre attention sur 2 procédures ChangePointerToIndex() et ChangeIndexToPointer() qui change les Pointeurs en index et vice et versa

Code : Tout sélectionner

EnableExplicit
Global gModeNew.b=#True,gFileName$
Enumeration 
      #MainForm
      #FicContact
      #Bt_Submit
      #Bt_Chancel
      #Bt_New
      #Bt_Edit
      #Bt_Delete
      #Lst_Contact
      #Txt_Name
      #Str_Name
      #Txt_Contry
      #Cb_Contry
      #MainMenu
      #M_NewFile
      #M_SaveFile
      #M_OpenFile
      #M_NewContact
      #M_EditContact
      #M_DeleteContact
      #M_EXIT
EndEnumeration
Structure Contry
      name$
EndStructure
Structure Contact
      name$
      *idContry
EndStructure
Structure Db
      List myContry.Contry()
      List myContact.Contact()
EndStructure
Global  myDb.DB
Declare FildContact()
Declare CloseContact()
Procedure Exit()
      End
EndProcedure
Procedure SaveContact()
      If GetGadgetText(#Str_Name)=""
            MessageRequester("Contact","Veuillez renseigner un nom")
            SetActiveGadget(#Str_Name)
            ProcedureReturn 
      EndIf
      If GetGadgetState(#Cb_Contry)=0
            MessageRequester("Contact","Veuillez choisir une localité")
            SetActiveGadget(#Cb_Contry)
            ProcedureReturn 
      EndIf
      If gModeNew
            AddElement(myDb\myContact())
      EndIf
      With myDb\myContact()
            \name$=GetGadgetText(#Str_Name)
            \idContry=GetGadgetItemData(#Cb_Contry,GetGadgetState(#Cb_Contry))
      EndWith
      FildContact()
      CloseContact()
EndProcedure
Procedure CloseContact()
      DisableWindow(#MainForm,#False)
      CloseWindow(#FicContact)
EndProcedure
Procedure OpenContact()
      Protected title$,name$,*IdContry
      Protected M=10,X=M,Y=M,W=380,H=30
      Select gModeNew
            Case #True
                  title$="Nouveau contact"
                  name$=""
                  *IdContry=-1
            Case #False
                  title$="Edition d'un contact"
                  name$=myDb\myContact()\name$
                  *IdContry=myDb\myContact()\idContry
      EndSelect
      DisableWindow(#MainForm,#True)
      OpenWindow(#FicContact,0,0,400,200,title$,#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
      TextGadget(#Txt_Name,X,Y,W,H,"Nom")
      Y+H
      StringGadget(#Str_Name,X,Y,W,H,name$)
      Y+H+M
      TextGadget(#Txt_Contry,X,Y,W,H,"Localité")
      Y+H
      ComboBoxGadget(#Cb_Contry,X,Y,W,H)
      Y+H+M
      ButtonGadget(#Bt_Submit,X,Y,(W/2)-M,H,"Valider")
      X+(W/2)+M
      ButtonGadget(#Bt_Chancel,X,Y,(W/2)-M,H,"Annuler")
      ; Remplissage du combo localité
      AddGadgetItem(#Cb_Contry,-1,"Faites votre choix")
      SetGadgetItemData(#Cb_Contry,CountGadgetItems(#Cb_Contry)-1,-1)
      ForEach myDb\myContry()
            With myDb\myContry()
                  AddGadgetItem(#Cb_Contry,-1,\name$)
                  SetGadgetItemData(#Cb_Contry,CountGadgetItems(#Cb_Contry)-1,@myDb\myContry())
            EndWith
      Next
      If *IdContry>-1
            Protected N
            ForEach myDb\myContry()
                  N+1
                  With myDb\myContry()
                        If @myDb\myContry()=*IdContry
                              SetGadgetState(#Cb_Contry,N)
                        EndIf
                  EndWith
            Next
            Else
                  SetGadgetState(#Cb_Contry,0)
            EndIf
      BindEvent(#PB_Event_CloseWindow,@CloseContact(),#FicContact)
      BindGadgetEvent(#Bt_Submit,@SaveContact())
      BindGadgetEvent(#Bt_Chancel,@CloseContact())
EndProcedure
Procedure NewContact()
      gModeNew=#True
      OpenContact()
EndProcedure
Procedure EditContact()
      Protected *id
      If GetGadgetState(#Lst_Contact)=-1: ProcedureReturn :EndIf
      *id=GetGadgetItemData(#Lst_Contact,GetGadgetState(#Lst_Contact))
      ChangeCurrentElement(myDb\myContact(),*id)
      gModeNew=#False
      OpenContact()
EndProcedure
Procedure DeleteContact()
      Protected *id
      If GetGadgetState(#Lst_Contact)=-1:ProcedureReturn :EndIf
      If MessageRequester("Suppression d'un contact","Etes-vous sure?",#PB_MessageRequester_YesNo)=#PB_MessageRequester_No
            ProcedureReturn 
      EndIf
      *id=GetGadgetItemData(#Lst_Contact,GetGadgetState(#Lst_Contact))
      ChangeCurrentElement(myDb\myContact(),*id)
      DeleteElement(myDb\myContact())
      FildContact()
EndProcedure
Procedure FildContact()
      Protected txt$
      ClearGadgetItems(#Lst_Contact)
      ForEach myDb\myContact()
            With myDb\myContact()
                  ChangeCurrentElement(myDb\myContry(),\idContry)
                  txt$=\name$+Chr(10)+myDb\myContry()\name$
                  AddGadgetItem(#Lst_Contact,-1,txt$)
                  SetGadgetItemData(#Lst_Contact,CountGadgetItems(#Lst_Contact)-1,@myDb\myContact())
            EndWith
      Next
EndProcedure
Procedure ChangeIndexToPointer()
      ForEach myDb\myContact()
            SelectElement(myDb\myContry(),myDb\myContact()\idContry)
            myDb\myContact()\idContry=@myDb\myContry()
      Next
EndProcedure
Procedure ChangePointerToIndex()
      ForEach myDb\myContact()
            ChangeCurrentElement(myDb\myContry(),myDb\myContact()\idContry)
            myDb\myContact()\idContry=ListIndex(myDb\myContry())
      Next
EndProcedure
Procedure NewFile()
       ClearStructure(@myDb,Db)
       InitializeStructure(@myDb,Db)
       FildContact()
       gFileName$=""
EndProcedure
Procedure pOpenFile()
      Protected file$,filter$
      filter$="DataBase file |*.mdb"
      file$=OpenFileRequester("Choisissez la base de donnée à ouvrir","",filter$,1)
      If file$<>""
            Protected myJson
            ClearStructure(@myDb,Db)
            InitializeStructure(@myDb,Db)
            myJson=LoadJSON(#PB_Any,file$,#PB_JSON_NoCase)
            If myJson=0
                  MessageRequester("Json Error","Load Json Error of line "+JSONErrorLine()+" : "+JSONErrorPosition())
                  ProcedureReturn #False
            EndIf
            ExtractJSONStructure(JSONValue(myJson),@myDb,Db)        
            gFileName$=file$
            ChangeIndexToPointer()
            FildContact()
            ProcedureReturn #True
      EndIf
EndProcedure
Procedure SaveFile()
      Protected file$,myJson
      Protected Filter$="Db file |*.mdb"
      ChangePointerToIndex()
      If gFileName$=""
            file$=SaveFileRequester("Sauvegarde de la base de donnée","my_database.mdb",Filter$,1)
            If file$="":ProcedureReturn :EndIf
            ;Ajout de l'extention si nécessaire
            If Right(file$,4)<>".mdb"
                  file$+".mdb"
            EndIf
            gFileName$=file$
      EndIf
      myJson=CreateJSON(#PB_Any)
      InsertJSONStructure(JSONValue(myJson),@myDb,Db)
      If SaveJSON(myJson,gFileName$,#PB_JSON_PrettyPrint)=0
            MessageRequester("Erreur json file","Impossible de suavegarder le fichier")
            gFileName$=""
            ChangeIndexToPointer()
            ProcedureReturn #False
      EndIf
       ChangeIndexToPointer()
EndProcedure
Procedure AddContry()
      Protected N
      For N=1 To 30
            AddElement(myDb\myContry())
            With myDb\myContry()
                  \name$="Localité "+N
            EndWith
      Next
EndProcedure
Procedure OpenMainForm()
      OpenWindow(#MainForm,0,0,800,600,"Contact",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
      ListIconGadget(#Lst_Contact,50,50,600,500,"Nom",300,#PB_ListIcon_FullRowSelect)
      AddGadgetColumn(#Lst_Contact,1,"Localité",300)
      FildContact()
      CreateMenu(#MainMenu,WindowID(#MainForm))
      MenuTitle("Fichier")
      MenuItem(#M_NewFile,"Nouveau")
      MenuItem(#M_OpenFile,"Ouvrir")
      MenuItem(#M_SaveFile,"Sauver")
      MenuBar()
      MenuItem(#M_EXIT,"Quitter")
      MenuTitle("Contact")
      MenuItem(#M_NewContact,"Nouveau")
      MenuItem(#M_EditContact,"Editer")
      MenuItem(#M_DeleteContact,"Supprimer")
      ButtonGadget(#Bt_New,660,50,100,30,"Nouveau")
      ButtonGadget(#Bt_Edit,660,100,100,30,"Editer")
      ButtonGadget(#Bt_Delete,660,150,100,30,"Supprimer")
      BindEvent(#PB_Event_CloseWindow,@Exit(),#MainForm)
      BindGadgetEvent(#Bt_New,@NewContact())
      BindGadgetEvent(#Bt_Edit,@EditContact())
      BindGadgetEvent(#Bt_Delete,@DeleteContact())
      BindMenuEvent(#MainMenu,#M_NewFile,@NewFile())
      BindMenuEvent(#MainMenu,#M_OpenFile,@pOpenFile())
      BindMenuEvent(#MainMenu,#M_SaveFile,@SaveFile())
      BindMenuEvent(#MainMenu,#M_NewContact,@NewContact())
      BindMenuEvent(#MainMenu,#M_EditContact,@EditContact())
      BindMenuEvent(#MainMenu,#M_DeleteContact,@DeleteContact())
      BindMenuEvent(#MainMenu,#M_EXIT,@Exit())
EndProcedure
AddContry()
OpenMainForm()
Repeat :WaitWindowEvent():ForEver
Windows 10 64 bits PB: 5.70 ; 5.72 LST
Work at Centre Spatial de Liège
Haut
Avatar de l’utilisateur
Micoute
Messages : 2584
Inscription : dim. 02/oct./2011 16:17
Localisation : 35520 La Mézière

Re: Base de données avec Json

Message par Micoute »

Bonsoir microdevweb et merci infiniment pour ce partage qui est, comme diraient mes enfants, de la balle ! Félicitations, c'est du très bon travail !
Microsoft Windows 10 Famille 64 bits : Carte mère : ASRock 970 Extreme3 R2.0 : Carte Graphique NVIDIA GeForce RTX 3080 : Processeur AMD FX 6300 6 cœurs 12 threads 3,50 GHz PB 6.20 LTS (x64)
Un homme doit être poli, mais il doit aussi être libre !
Haut
Avatar de l’utilisateur
Kwai chang caine
Messages : 6989
Inscription : sam. 23/sept./2006 18:32
Localisation : Isere

Re: Base de données avec Json

Message par Kwai chang caine »

Merci Microdevweb
Moi par contre j'ai pas pu créer une entrée, il me demande une localité à choisir et il n'y en a pas dans la combo qui n'est pas editable :|
ImageLe bonheur est une route...
Pas une destination

PureBasic Forum Officiel - Site PureBasic
Haut
Répondre

Revenir à « Trucs et astuces »