PureBasic

Forums PureBasic - Français
http://forums.purebasic.com/french/

TUTO Faire de jolies tables de base de données

http://forums.purebasic.com/french/viewtopic.php?t=16682

Page 1 sur 1

TUTO Faire de jolies tables de base de données

Publié : mar. 09/mai/2017 10:50
par microdevweb
PureBasic offre d'énormes possibilités, et maintenant encore plus avec la version 5.60 qui permet l'utilisation de canvas comme container.

Dans ce exemple je vous montre comment créer une jolie table (simple 247 lignes)

:!: Vous devez sauver le code, car une fichier de base de données sera créé

Première partie: (affichage simple ci-dessous)

Deuxième partie: (ajout de la sélection) ICI

Troisième et dernière partie : (gestion de colonnes plus grandes que la table) ICI

Code : Tout sélectionner

; ***************************************************************************************************************
; AUTHEUR    : MicrodevWeb
; Version PB : 5.60
; Comment faire de belle table ?
; ***************************************************************************************************************
Enumeration 
  #MainForm
  #MainCanvas
  #BtFiltersName
  #Scroll
  #Filters
EndEnumeration
Global DbName.s="DbTeste.sqlite"
Global FontTitle=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality|#PB_Font_Bold)
Global FontLine=LoadFont(#PB_Any,"Arial",11,#PB_Font_HighQuality)
Global ScrollOn.b=#False,FiltersOn.b=#False
UseSQLiteDatabase()

Procedure Exit()
  CloseWindow(#MainForm)
  End
EndProcedure
Procedure DbUpdate(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseUpdate(Db,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  CloseDatabase(DB)
  ProcedureReturn DB
EndProcedure
Procedure DbQuery(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseQuery(DB,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  ProcedureReturn DB
EndProcedure
Procedure.s GetRdmTxt() 
  Protected i,n,txt.s
  Protected Car.s="a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,y,z"
  n=Random(20,5)
  For i=0 To n
    txt+StringField(Car,Random(26,1),",")
  Next
  ProcedureReturn txt
EndProcedure
Procedure ManageDb()
  Protected  query.s,idDb,i
  ; Création du fichier si il n'existe pas
  If FileSize(DbName)=-1
    CreateFile(0,DbName)
    CloseFile(0)
    ; Création du fichier client
    query="CREATE TABLE client ("
    query+"id INTEGER PRIMARY KEY AUTOINCREMENT,"
    query+"nom TEXT,"
    query+"localite TEXT)"
    If Not DbUpdate(query)
      Exit()
    EndIf
    ; On va créer quelques enregistrements pour le teste :)
    For i=0 To 100
      query="INSERT INTO client (nom,localite) VALUES ("
      query+Chr(34)+GetRdmTxt()+Chr(34)+","
      query+Chr(34)+GetRdmTxt()+Chr(34)+")"
      If Not DbUpdate(query)
        Exit()
      EndIf
    Next
  EndIf
EndProcedure
Procedure DrawColumnTitles()
  Protected w=400,x,y,h=30
  VectorSourceColor($FFFFFFFF)
  VectorFont(FontID(FontTitle))
  x=(w/2)-(VectorTextWidth("Nom")/2)
  Y=(H/2)-(VectorTextHeight("Nom")/2)
  MovePathCursor(x,y)
  DrawVectorText("Nom")
  x=w+((w/2)-(VectorTextWidth("Localité")/2))
  MovePathCursor(x,y)
  DrawVectorText("Localité")
EndProcedure
Procedure DrawColoredLines()
  Protected y=30,n=20,w=800,h=660/n,i,k,start
  If ScrollOn
    start=GetGadgetState(#Scroll)
  EndIf
  k=n+start
  For i=start+1 To k
    ; Détermine si lgn pair ou impair
    If i%2=0
      VectorSourceColor($FFFFFFFF)
    Else
      VectorSourceColor($FF008CFF)
    EndIf
    AddPathBox(0,y,800,30)
    FillPath()
    y+30
  Next
EndProcedure
Procedure ManageScroll()
  Protected query.s,idDb,max
  Protected Filters.s=GetGadgetText(#Filters)
  ; Compte le nbr de record dans la table
  query="SELECT COUNT(*) FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  FirstDatabaseRow(idDb)
  ; si plus de record que de lignes
  If GetDatabaseLong(idDb,0)>20
    max=GetDatabaseLong(idDb,0)-20
    HideGadget(#Scroll,#False)
    SetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum,max)
    ScrollOn=#True
  Else
    HideGadget(#Scroll,#True)
    ScrollOn=#False
  EndIf
  CloseDatabase(idDb)
EndProcedure
Procedure DrawDataLines()
  Protected idDb,query.s,x=5,y=30,w=390,lmtEnd,Txt.s,yt
  Protected Filters.s=GetGadgetText(#Filters)
  VectorFont(FontID(FontLine))
  VectorSourceColor($FF000000)
  If ScrollOn
    lmtEnd=GetGadgetState(#Scroll)
  EndIf
  query="SELECT id,nom,localite FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  query+" ORDER BY nom"
  query+" LIMIT 20 OFFSET "+Str(lmtEnd)
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  While NextDatabaseRow(idDb)
    Txt=GetDatabaseString(idDb,1)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    x=5
    yt=y+15-(VectorTextHeight(Txt)/2)
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    x+w+10
    Txt=GetDatabaseString(idDb,2)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    y+30
  Wend
  CloseDatabase(idDb)
EndProcedure
Procedure DrawZone()
  Protected x,w
  VectorSourceColor($FF000000)
  AddPathBox(0,0,800,600)
  MovePathCursor(0,30)
  AddPathLine(800,30)
  MovePathCursor(400,0)
  AddPathLine(400,600)
  StrokePath(1.5)
EndProcedure
Procedure DrawTable()
  ManageScroll()
  StartVectorDrawing(CanvasVectorOutput(#MainCanvas))
  ; On efface
  VectorSourceColor($FF808080)
  FillVectorOutput()
  DrawColumnTitles()
  DrawColoredLines()
  DrawDataLines()
  DrawZone()
  StopVectorDrawing()
EndProcedure
Procedure EventFilters()
  If EventType()=#PB_EventType_Change
    DrawTable()
  EndIf
EndProcedure
Procedure EventBtFilter()
  If FiltersOn
    FiltersOn=#False
    HideGadget(#Filters,#True)
    SetGadgetText(#Filters,"")
    DrawTable()
  Else
    FiltersOn=#True
    HideGadget(#Filters,#False)
    SetActiveGadget(#Filters)
  EndIf
EndProcedure
Procedure EventScroll()
  DrawTable()
EndProcedure
Procedure OpenMainForm()
  OpenWindow(#MainForm,0,0,800,600,"Crée de belles tables",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  CanvasGadget(#MainCanvas,0,0,800,600,#PB_Canvas_Container|#PB_Canvas_Keyboard)
  ScrollBarGadget(#Scroll,775,0,25,600,0,1,10,#PB_ScrollBar_Vertical)
  HideGadget(#Scroll,#True)
  BindGadgetEvent(#Scroll,@EventScroll())
  StringGadget(#Filters,0,0,370,30,"")
  HideGadget(#Filters,#True)
  BindGadgetEvent(#Filters,@EventFilters())
  ButtonGadget(#BtFiltersName,370,0,30,30,"...")
  BindGadgetEvent(#BtFiltersName,@EventBtFilter())
  CloseGadgetList()
  
  DrawTable()
  BindEvent(#PB_Event_CloseWindow,@Exit())
EndProcedure

ManageDb()

OpenMainForm()

Repeat
  WaitWindowEvent()
ForEver

Re: TUTO Faire de jolies tables

Publié : mar. 09/mai/2017 15:44
par Kwai chang caine
Marche nickel
Merci pour le partage 8)

Re: TUTO Faire de jolies tables

Publié : mar. 09/mai/2017 22:31
par Ar-S
Salut microdevweb,
Merci pour ce code.

Re: TUTO Faire de jolies tables

Publié : mer. 10/mai/2017 7:00
par microdevweb
Deuxième parties :

Ici on ajoute la possibilité de sélection dans la table ainsi que le déplacement de l’ascenseur avec la molette de la souris, on peut également passer d'une ligne à l'autre avec les flèches du clavier. J'ai également corrigé un petit bug en effet il y a 19 lignes de table et non pas 20 (ligne de code 348)

:arrow: A suivre, gestion de colonne plus grande que la table :wink:

Code : Tout sélectionner

; ***************************************************************************************************************
; AUTHEUR    : MicrodevWeb
; Version PB : 5.60
; Comment faire de belle table ?
; ***************************************************************************************************************
Enumeration 
  #MainForm
  #MainCanvas
  #BtFiltersName
  #Scroll
  #Filters
EndEnumeration
Global DbName.s="DbTeste.sqlite"
Global FontTitle=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality|#PB_Font_Bold)
Global FontLine=LoadFont(#PB_Any,"Arial",11,#PB_Font_HighQuality)
Global FontSelected=LoadFont(#PB_Any,"Arial",11,#PB_Font_HighQuality|#PB_Font_Bold)
Global ScrollOn.b=#False,FiltersOn.b=#False,IdSelected=-1,CurrentLine=-1
Global NewList myRecord()
UseSQLiteDatabase()
EnableExplicit
Procedure Exit()
  CloseWindow(#MainForm)
  End
EndProcedure
Procedure DbUpdate(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseUpdate(Db,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  CloseDatabase(DB)
  ProcedureReturn DB
EndProcedure
Procedure DbQuery(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseQuery(DB,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  ProcedureReturn DB
EndProcedure
Procedure.s GetRdmTxt() 
  Protected i,n,txt.s
  Protected Car.s="a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,y,z"
  n=Random(20,5)
  For i=0 To n
    txt+StringField(Car,Random(26,1),",")
  Next
  ProcedureReturn txt
EndProcedure
Procedure ManageDb()
  Protected  query.s,idDb,i
  ; Création du fichier si il n'existe pas
  If FileSize(DbName)=-1
    CreateFile(0,DbName)
    CloseFile(0)
    ; Création du fichier client
    query="CREATE TABLE client ("
    query+"id INTEGER PRIMARY KEY AUTOINCREMENT,"
    query+"nom TEXT,"
    query+"localite TEXT)"
    If Not DbUpdate(query)
      Exit()
    EndIf
    ; On va créer quelques enregistrements pour le teste :)
    For i=0 To 100
      query="INSERT INTO client (nom,localite) VALUES ("
      query+Chr(34)+GetRdmTxt()+Chr(34)+","
      query+Chr(34)+GetRdmTxt()+Chr(34)+")"
      If Not DbUpdate(query)
        Exit()
      EndIf
    Next
  EndIf
EndProcedure
Procedure DrawColumnTitles()
  Protected w=400,x,y,h=30
  VectorSourceColor($FFFFFFFF)
  VectorFont(FontID(FontTitle))
  x=(w/2)-(VectorTextWidth("Nom")/2)
  Y=(H/2)-(VectorTextHeight("Nom")/2)
  MovePathCursor(x,y)
  DrawVectorText("Nom")
  x=w+((w/2)-(VectorTextWidth("Localité")/2))
  MovePathCursor(x,y)
  DrawVectorText("Localité")
EndProcedure
Procedure DrawColoredLines()
  Protected y=30,n=19,w=800,h=660/n,i,k,start
  If ScrollOn
    start=GetGadgetState(#Scroll)
  EndIf
  k=n+start
  For i=start+1 To k
    ; Détermine si lgn pair ou impair
    If i%2=0
      VectorSourceColor($FFFFFFFF)
    Else
      VectorSourceColor($FF008CFF)
    EndIf
    AddPathBox(0,y,800,30)
    FillPath()
    y+30
  Next
EndProcedure
Procedure ManageScroll()
  Protected query.s,idDb,max
  Protected Filters.s=GetGadgetText(#Filters)
  ; Compte le nbr de record dans la table
  query="SELECT COUNT(*) FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  FirstDatabaseRow(idDb)
  ; si plus de record que de lignes
  If GetDatabaseLong(idDb,0)>19
    max=GetDatabaseLong(idDb,0)-19
    HideGadget(#Scroll,#False)
    SetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum,max)
    ScrollOn=#True
  Else
    HideGadget(#Scroll,#True)
    ScrollOn=#False
  EndIf
  CloseDatabase(idDb)
EndProcedure
Procedure DrawDataLines()
  Protected idDb,query.s,x=5,y=30,w=390,lmtEnd,Txt.s,yt,n
  Protected Filters.s=GetGadgetText(#Filters)
  If ScrollOn
    lmtEnd=GetGadgetState(#Scroll)
  EndIf
  query="SELECT id,nom,localite FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  query+" ORDER BY nom"
  query+" LIMIT 19 OFFSET "+Str(lmtEnd)
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  ClearList(myRecord())
  While NextDatabaseRow(idDb)
    ; Si aucune ligne n'est encore sélectionnée on sélectionne la première ligne
    If IdSelected=-1 And n=0
      IdSelected=GetDatabaseLong(idDb,0)
      CurrentLine=0
    EndIf
    ; Si la ligne en cour d'affichage est égal à ligne sélectionnée
    If GetDatabaseLong(idDb,0)=IdSelected
      ; On déssine une boîte de sélection
      AddPathBox(0,y,GadgetWidth(#MainCanvas),30)
      VectorSourceColor($FFFF0000)
      FillPath()
      VectorFont(FontID(FontSelected))
      VectorSourceColor($FFF5F5F5)
    Else
      VectorFont(FontID(FontLine))
      VectorSourceColor($FF000000)
    EndIf
    Txt=GetDatabaseString(idDb,1)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    x=5
    yt=y+15-(VectorTextHeight(Txt)/2)
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    x+w+10
    Txt=GetDatabaseString(idDb,2)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    ; Ici on mémorise l'id de la ligne de table de la bd
    AddElement(myRecord())
    myRecord()=GetDatabaseLong(idDb,0)
    y+30
  Wend
  CloseDatabase(idDb)
EndProcedure
Procedure DrawZone()
  Protected x,w
  VectorSourceColor($FF000000)
  AddPathBox(0,0,800,600)
  MovePathCursor(0,30)
  AddPathLine(800,30)
  MovePathCursor(400,0)
  AddPathLine(400,600)
  StrokePath(1.5)
EndProcedure
Procedure DrawTable()
  ManageScroll()
  StartVectorDrawing(CanvasVectorOutput(#MainCanvas))
  ; On efface
  VectorSourceColor($FF808080)
  FillVectorOutput()
  DrawColumnTitles()
  DrawColoredLines()
  DrawDataLines()
  DrawZone()
  StopVectorDrawing()
EndProcedure
Procedure EventFilters()
  If EventType()=#PB_EventType_Change
    IdSelected=-1
    CurrentLine=-1
    DrawTable()
  EndIf
EndProcedure
Procedure EventBtFilter()
  If FiltersOn
    FiltersOn=#False
    HideGadget(#Filters,#True)
    SetGadgetText(#Filters,"")
    DrawTable()
  Else
    FiltersOn=#True
    HideGadget(#Filters,#False)
    SetActiveGadget(#Filters)
  EndIf
EndProcedure
Procedure EventScroll()
  DrawTable()
EndProcedure
Procedure SelectLine()
  Protected mY=GetGadgetAttribute(#MainCanvas,#PB_Canvas_MouseY)-30
  Protected n
  ;Déterminer la ligne de table survolée par la souris
  n=Round(my/30,#PB_Round_Down)
  SelectElement(myRecord(),n)
  IdSelected=myRecord()
  CurrentLine=n
  DrawTable()
  Debug "Id sélectionné "+Str(IdSelected)
EndProcedure
Procedure EventCanvas()
  Protected i
  Select EventType()
    Case #PB_EventType_LeftClick
      SelectLine()
    Case #PB_EventType_MouseWheel
      i=GetGadgetState(#Scroll)
      Select GetGadgetAttribute(#MainCanvas,#PB_Canvas_WheelDelta)
        Case -1
          If i<GetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum)
            SetGadgetState(#Scroll,i+1)
            DrawTable()
          EndIf
        Case 1
          If i>0
            SetGadgetState(#Scroll,i-1)
            DrawTable()
          EndIf
      EndSelect
  EndSelect
EndProcedure
Procedure myEventMenu()
  Protected i=GetGadgetState(#Scroll)
  Protected max=GetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum)
  If ListSize(myRecord())=0
    ProcedureReturn 
  EndIf
  SelectElement(myRecord(),CurrentLine)
  Select EventMenu()
    Case $FF0 ; Up
              ; si on est sur la première ligne de table, mais pas sur la première ligne de data
      If CurrentLine=0 And i>0
        SetGadgetState(#Scroll,i-1)
        DrawTable()
        FirstElement(myRecord())
        IdSelected=myRecord()
        DrawTable()
        ProcedureReturn 
      EndIf
      If PreviousElement(myRecord())
        IdSelected=myRecord()
        CurrentLine-1
        DrawTable()
      EndIf 
    Case $FF1 ;Down
              ; si on est sur la dernière ligne de la table, mais pas sur la dernière ligne de data
      If CurrentLine=18 And i<max
        SetGadgetState(#Scroll,i+1)
        DrawTable()
        LastElement(myRecord())
        IdSelected=myRecord()
        DrawTable()
        ProcedureReturn 
      EndIf
      
      If NextElement(myRecord())
        IdSelected=myRecord()
        CurrentLine+1
        DrawTable()
      EndIf 
  EndSelect
EndProcedure
Procedure OpenMainForm()
  OpenWindow(#MainForm,0,0,800,600,"Crée de belles tables",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  CanvasGadget(#MainCanvas,0,0,800,600,#PB_Canvas_Container|#PB_Canvas_Keyboard)
  BindGadgetEvent(#MainCanvas,@EventCanvas())
  ScrollBarGadget(#Scroll,775,0,25,600,0,1,10,#PB_ScrollBar_Vertical)
  HideGadget(#Scroll,#True)
  BindGadgetEvent(#Scroll,@EventScroll())
  StringGadget(#Filters,0,0,370,30,"")
  HideGadget(#Filters,#True)
  BindGadgetEvent(#Filters,@EventFilters())
  ButtonGadget(#BtFiltersName,370,0,30,30,"...")
  BindGadgetEvent(#BtFiltersName,@EventBtFilter())
  CloseGadgetList()
  ; Ajout de raccourcis clavier pour changer la sélection avec les flèches
  AddKeyboardShortcut(#MainForm,#PB_Shortcut_Up,$FF0)
  AddKeyboardShortcut(#MainForm,#PB_Shortcut_Down,$FF1)
  BindEvent(#PB_Event_Menu,@myEventMenu(),#MainForm)
  DrawTable()
  BindEvent(#PB_Event_CloseWindow,@Exit())
EndProcedure

ManageDb()

OpenMainForm()

Repeat
  WaitWindowEvent()
ForEver

Re: TUTO Faire de jolies tables

Publié : mer. 10/mai/2017 8:18
par Zorro
Je crois comprendre qu'il s'agit de "Tables" de base de données !?

car a lire le tire, j'ai pensé a comment faire une Table 3D (Ogre)
je pense qu'une petite precision dans le titre ferai gagner du temps pour les recherches futures ...:)

d'autant que je ne vois pas ce qu'il y a de "jolie" dans une table de base de données ... :mrgreen:

Re: TUTO Faire de jolies tables de base de données

Publié : mer. 10/mai/2017 8:27
par microdevweb
@Zorro,

Pour te faire plaisir j'ai modifié le titre...

Re: TUTO Faire de jolies tables de base de données

Publié : mer. 10/mai/2017 8:28
par microdevweb
Troisième et dernière partie :

Gestion de colonnes plus grandes (code 405 lignes)

Code : Tout sélectionner

; ***************************************************************************************************************
; AUTHEUR    : MicrodevWeb
; Version PB : 5.60
; Comment faire de belle table ?
; ***************************************************************************************************************
Enumeration 
  #MainForm
  #MainCanvas
  #BtFiltersName
  #Scroll
  #ScrollH
  #Filters
EndEnumeration
#ImgTable=0
Global DbName.s="DbTeste.sqlite"
Global FontTitle=LoadFont(#PB_Any,"Arial",12,#PB_Font_HighQuality|#PB_Font_Bold)
Global FontLine=LoadFont(#PB_Any,"Arial",11,#PB_Font_HighQuality)
Global FontSelected=LoadFont(#PB_Any,"Arial",11,#PB_Font_HighQuality|#PB_Font_Bold)
Global ScrollOn.b=#False,FiltersOn.b=#False,IdSelected=-1,CurrentLine=-1
Global NewList myRecord()
UseSQLiteDatabase()
EnableExplicit
Declare DrawCanvas()
Procedure Exit()
  CloseWindow(#MainForm)
  End
EndProcedure
Procedure ManageMaxScrollH()
  Protected max
  max=1200-800
  If ScrollOn
    max+25
  EndIf
  SetGadgetAttribute(#ScrollH,#PB_ScrollBar_Maximum,max)
EndProcedure
Procedure DbUpdate(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseUpdate(Db,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  CloseDatabase(DB)
  ProcedureReturn DB
EndProcedure
Procedure DbQuery(query.s)
  Protected Db
  Db=OpenDatabase(#PB_Any,DbName,"","")
  If Not DB
    MessageRequester("Database Error","Can't open database",#PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
  If Not DatabaseQuery(DB,query)
    MessageRequester("Database Error",DatabaseError(),#PB_MessageRequester_Error)
    CloseDatabase(DB)
    ProcedureReturn 0
  EndIf
  ProcedureReturn DB
EndProcedure
Procedure.s GetRdmTxt() 
  Protected i,n,txt.s
  Protected Car.s="a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,v,w,x,y,z"
  n=Random(20,5)
  For i=0 To n
    txt+StringField(Car,Random(26,1),",")
  Next
  ProcedureReturn txt
EndProcedure
Procedure ManageDb()
  Protected  query.s,idDb,i
  ; Création du fichier si il n'existe pas
  If FileSize(DbName)=-1
    CreateFile(0,DbName)
    CloseFile(0)
    ; Création du fichier client
    query="CREATE TABLE client ("
    query+"id INTEGER PRIMARY KEY AUTOINCREMENT,"
    query+"nom TEXT,"
    query+"localite TEXT)"
    If Not DbUpdate(query)
      Exit()
    EndIf
    ; On va créer quelques enregistrements pour le teste :)
    For i=0 To 100
      query="INSERT INTO client (nom,localite) VALUES ("
      query+Chr(34)+GetRdmTxt()+Chr(34)+","
      query+Chr(34)+GetRdmTxt()+Chr(34)+")"
      If Not DbUpdate(query)
        Exit()
      EndIf
    Next
  EndIf
EndProcedure
Procedure DrawColumnTitles()
  Protected w=600,x,y,h=30
  VectorSourceColor($FFFFFFFF)
  VectorFont(FontID(FontTitle))
  x=(w/2)-(VectorTextWidth("Nom")/2)
  Y=(H/2)-(VectorTextHeight("Nom")/2)
  MovePathCursor(x,y)
  DrawVectorText("Nom")
  x=w+((w/2)-(VectorTextWidth("Localité")/2))
  MovePathCursor(x,y)
  DrawVectorText("Localité")
EndProcedure
Procedure DrawColoredLines()
  Protected y=30,n=19,w=1200,h=660/n,i,k,start
  If ScrollOn
    start=GetGadgetState(#Scroll)
  EndIf
  k=n+start
  For i=start+1 To k
    ; Détermine si lgn pair ou impair
    If i%2=0
      VectorSourceColor($FFFFFFFF)
    Else
      VectorSourceColor($FF008CFF)
    EndIf
    AddPathBox(0,y,w,30)
    FillPath()
    y+30
  Next
EndProcedure
Procedure ManageScroll()
  Protected query.s,idDb,max
  Protected Filters.s=GetGadgetText(#Filters)
  ; Compte le nbr de record dans la table
  query="SELECT COUNT(*) FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  FirstDatabaseRow(idDb)
  ; si plus de record que de lignes
  If GetDatabaseLong(idDb,0)>19
    max=GetDatabaseLong(idDb,0)-19
    HideGadget(#Scroll,#False)
    SetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum,max)
    ScrollOn=#True
  Else
    HideGadget(#Scroll,#True)
    ScrollOn=#False
  EndIf
  CloseDatabase(idDb)
  ManageMaxScrollH()
EndProcedure
Procedure DrawDataLines()
  Protected idDb,query.s,x=5,y=30,w=590,lmtEnd,Txt.s,yt,n
  Protected Filters.s=GetGadgetText(#Filters)
  If ScrollOn
    lmtEnd=GetGadgetState(#Scroll)
  EndIf
  query="SELECT id,nom,localite FROM client"
  If Filters<>""
    query+" WHERE nom LIKE "+Chr(34)+Filters+"%"+Chr(34)
  EndIf
  query+" ORDER BY nom"
  query+" LIMIT 19 OFFSET "+Str(lmtEnd)
  idDb=DbQuery(query)
  If Not idDb
    Exit()
  EndIf
  ClearList(myRecord())
  While NextDatabaseRow(idDb)
    ; Si aucune ligne n'est encore sélectionnée on sélectionne la première ligne
    If IdSelected=-1 And n=0
      IdSelected=GetDatabaseLong(idDb,0)
      CurrentLine=0
    EndIf
    ; Si la ligne en cour d'affichage est égal à ligne sélectionnée
    If GetDatabaseLong(idDb,0)=IdSelected
      ; On déssine une boîte de sélection
      AddPathBox(0,y,ImageWidth(#ImgTable),30)
      VectorSourceColor($FFFF0000)
      FillPath()
      VectorFont(FontID(FontSelected))
      VectorSourceColor($FFF5F5F5)
    Else
      VectorFont(FontID(FontLine))
      VectorSourceColor($FF000000)
    EndIf
    Txt=GetDatabaseString(idDb,1)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    x=5
    yt=y+15-(VectorTextHeight(Txt)/2)
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    x+w+10
    Txt=GetDatabaseString(idDb,2)
    ; Concaténation du texte si nécessaire
    While VectorTextWidth(Txt)>w
      Txt=Left(Txt,Len(Txt)-4)
      Txt+"..."
    Wend
    MovePathCursor(x,yt)
    DrawVectorText(Txt)
    ; Ici on mémorise l'id de la ligne de table de la bd
    AddElement(myRecord())
    myRecord()=GetDatabaseLong(idDb,0)
    y+30
  Wend
  CloseDatabase(idDb)
EndProcedure
Procedure DrawZone()
  Protected x,w
  VectorSourceColor($FF000000)
  AddPathBox(0,0,1200,600)
  MovePathCursor(0,30)
  AddPathLine(1200,30)
  MovePathCursor(600,0)
  AddPathLine(600,600)
  StrokePath(1.5)
EndProcedure
Procedure DrawTable()
  ManageScroll()
  StartVectorDrawing(ImageVectorOutput(#ImgTable))
  ; On efface
  VectorSourceColor($FF808080)
  FillVectorOutput()
  DrawColumnTitles()
  DrawColoredLines()
  DrawDataLines()
  DrawZone()
  StopVectorDrawing()
EndProcedure
Procedure EventFilters()
  If EventType()=#PB_EventType_Change
    IdSelected=-1
    CurrentLine=-1
    DrawTable()
    DrawCanvas()
  EndIf
EndProcedure
Procedure EventBtFilter()
  If FiltersOn
    FiltersOn=#False
    IdSelected=-1
    HideGadget(#Filters,#True)
    SetGadgetText(#Filters,"")
    DrawTable()
    DrawCanvas()
  Else
    FiltersOn=#True
    HideGadget(#Filters,#False)
    SetActiveGadget(#Filters)
  EndIf
EndProcedure
Procedure EventScroll()
  DrawTable()
  DrawCanvas()
EndProcedure
Procedure SelectLine()
  Protected mY=GetGadgetAttribute(#MainCanvas,#PB_Canvas_MouseY)-30
  Protected n
  ;Déterminer la ligne de table survolée par la souris
  n=Round(my/30,#PB_Round_Down)
  SelectElement(myRecord(),n)
  IdSelected=myRecord()
  CurrentLine=n
  DrawTable()
  DrawCanvas()
  Debug "Id sélectionné "+Str(IdSelected)
EndProcedure
Procedure EventCanvas()
  Protected i
  Select EventType()
    Case #PB_EventType_LeftClick
      SelectLine()
    Case #PB_EventType_MouseWheel
      i=GetGadgetState(#Scroll)
      Select GetGadgetAttribute(#MainCanvas,#PB_Canvas_WheelDelta)
        Case -1
          If i<GetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum)
            SetGadgetState(#Scroll,i+1)
            DrawTable()
            DrawCanvas()
          EndIf
        Case 1
          If i>0
            SetGadgetState(#Scroll,i-1)
            DrawTable()
            DrawCanvas()
          EndIf
      EndSelect
  EndSelect
EndProcedure
Procedure myEventMenu()
  Protected i=GetGadgetState(#Scroll)
  Protected max=GetGadgetAttribute(#Scroll,#PB_ScrollBar_Maximum)
  If ListSize(myRecord())=0
    ProcedureReturn 
  EndIf
  SelectElement(myRecord(),CurrentLine)
  Select EventMenu()
    Case $FF0 ; Up
              ; si on est sur la première ligne de table, mais pas sur la première ligne de data
      If CurrentLine=0 And i>0
        SetGadgetState(#Scroll,i-1)
        DrawTable()
        FirstElement(myRecord())
        IdSelected=myRecord()
        DrawTable()
        DrawCanvas()
        ProcedureReturn 
      EndIf
      If PreviousElement(myRecord())
        IdSelected=myRecord()
        CurrentLine-1
        DrawTable()
        DrawCanvas()
      EndIf 
    Case $FF1 ;Down
              ; si on est sur la dernière ligne de la table, mais pas sur la dernière ligne de data
      If CurrentLine=18 And i<max
        SetGadgetState(#Scroll,i+1)
        DrawTable()
        LastElement(myRecord())
        IdSelected=myRecord()
        DrawTable()
        DrawCanvas()
        ProcedureReturn 
      EndIf
      
      If NextElement(myRecord())
        IdSelected=myRecord()
        CurrentLine+1
        DrawTable()
        DrawCanvas()
      EndIf 
  EndSelect
EndProcedure
Procedure DrawCanvas()
  Protected img,x,w,h
  x=GetGadgetState(#ScrollH)
  If ScrollOn
    w=775
  Else
    w=800
  EndIf
  h=600
  img=GrabImage(#ImgTable,#PB_Any,x,0,w,h)
  StartVectorDrawing(CanvasVectorOutput(#MainCanvas))
  VectorSourceColor($FFD3D3D3)
  FillVectorOutput()
  MovePathCursor(0,0)
  DrawVectorImage(ImageID(img))
  FreeImage(img)
  StopVectorDrawing()
EndProcedure
Procedure EventScrollH()
  Protected X=570-GetGadgetState(#ScrollH)
  ResizeGadget(#BtFiltersName,x,#PB_Ignore,#PB_Ignore,#PB_Ignore)
  X=0-GetGadgetState(#ScrollH)
  ResizeGadget(#Filters,x,#PB_Ignore,#PB_Ignore,#PB_Ignore)
  DrawCanvas()
EndProcedure
Procedure OpenMainForm()
  Protected max
  ; Création de l'image pour la table
  CreateImage(#ImgTable,1200,600)
  OpenWindow(#MainForm,0,0,800,625,"Crée de belles tables",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  CanvasGadget(#MainCanvas,0,0,800,625,#PB_Canvas_Container|#PB_Canvas_Keyboard)
  BindGadgetEvent(#MainCanvas,@EventCanvas())
  ScrollBarGadget(#Scroll,775,0,25,600,0,1,10,#PB_ScrollBar_Vertical)
  HideGadget(#Scroll,#True)
  BindGadgetEvent(#Scroll,@EventScroll())
  ; ScrollBar horisontal pour le déplacement de la table
  ; Le maximum est égal à la largeur de l'image de la table - la largeur du canvas
  max=1200-800
  ScrollBarGadget(#ScrollH,0,600,775,25,0,max,10)
  BindGadgetEvent(#ScrollH,@EventScrollH())
  StringGadget(#Filters,0,0,570,30,"")
  HideGadget(#Filters,#True)
  BindGadgetEvent(#Filters,@EventFilters())
  ButtonGadget(#BtFiltersName,570,0,30,30,"...")
  BindGadgetEvent(#BtFiltersName,@EventBtFilter())
  CloseGadgetList()
  ; Ajout de raccourcis clavier pour changer la sélection avec les flèches
  AddKeyboardShortcut(#MainForm,#PB_Shortcut_Up,$FF0)
  AddKeyboardShortcut(#MainForm,#PB_Shortcut_Down,$FF1)
  BindEvent(#PB_Event_Menu,@myEventMenu(),#MainForm)
  DrawTable()
  DrawCanvas()
  BindEvent(#PB_Event_CloseWindow,@Exit())
EndProcedure

ManageDb()

OpenMainForm()

Repeat
  WaitWindowEvent()
ForEver

Re: TUTO Faire de jolies tables de base de données

Publié : mer. 10/mai/2017 14:37
par Zorro
pas pour me faire plaisir , juste pour etre plus clair :)
lorsque je suis venu dans ce topic, je croyais vraiment que c'etait un code pour la 3D
Fuseau horaire sur UTC+01:00
Page 1 sur 1

Développé par phpBB® Forum Software © phpBB Limited

Traduction française officielle © Qiaeru