j'avais fait ça, il y a quelques années, c'est sûr que maintenant, j'aurais bien du mal à le refaire.
Code : Tout sélectionner
;- Module Public
DeclareModule MesVectorGadgets
Declare GadgetCouleurBouton(id, x, y, dx, dy, texte.s, drapeaux = #PB_Button_Default)
Interface iGadget
GetID()
GetHandle()
GetType()
FreeGadget()
GetGadgetState()
SetGadgetState(Etat)
GetGadgetText.s()
SetGadgetText(Texte.s)
GetGadgetColor(TypeCouleur)
SetGadgetColor(TypeCouleur, Couleur)
GetGadgetFont()
SetGadgetFont(hPolice)
ResizeGadget(x, y, dx, dy)
HideGadget(Etat)
DisableGadget(Etat)
GadgetX()
GadgetY()
GadgetWidth()
GadgetHeight()
GetGadgetAttribute(Attribut)
SetGadgetAttribute(Attribut, Valeur)
EndInterface
EndDeclareModule
; -------------------------------------------------------------------------------------
;- Module Privé
Module MesVectorGadgets
EnableExplicit
;-- Constantes Internes
Enumeration
#CouleurBoutonEtatDefaut
#CouleurBoutonEtatSurvole
#CouleurBoutonEtatPresse
EndEnumeration
;-- Structure Interne
Structure sGadget
; Base
*tv.iGadget ; Table Virtuelle Fonctions
id.i ; Gadget PB_ID
type.i ; Gadget Type
; Données
x.i
y.i
dx.i
dy.i
texte.s
drapeaux.i
etat.i
etatCouleur.i
style.i
hPolice.i
couleurpremierplan.i
couleurfond.i
couleurbord.i
EndStructure
;-- Données Internes (Mémoire)
Global NewMap MesDonneesGadget.sGadget()
;-- Declaraton des fonctions de base Internes
Declare NouvelleDonnee(id)
Declare LibererDonnees(id)
;-- Declaration des Fonctions Internes
Declare DessinerBouton(*sGadget)
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- Fonctions Interface
Procedure MonObtenirID(*objet.sGadget)
Protected resultat
With *objet
resultat = \id
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirGestionnaire(*objet.sGadget)
Protected resultat
With *objet
If \type
resultat = GadgetID(\id)
EndIf
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirType(*objet.sGadget)
Protected resultat
With *objet
resultat = \type
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonLibererGadget(*objet.sGadget)
Protected resultat
With *objet
If \type
If IsGadget(\id)
FreeGadget(\id)
EndIf
resultat = LibererDonnees(\id)
EndIf
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirEtatGadget(*objet.sGadget)
Protected resultat
With *objet
resultat = \etat
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonDefinirEtatGadget(*objet.sGadget, Etat)
Protected resultat
With *objet
If \type
\etat = Etat
Select \type
Case #PB_GadgetType_Button : DessinerBouton(*objet)
EndSelect
EndIf
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure.s MonObtenirTexteGadget(*objet.sGadget)
Protected resultat.s
With *objet
resultat = \texte
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonDefinirTexteGadget(*objet.sGadget, Texte.s)
With *objet
If \type
\texte = Texte
Select \type
Case #PB_GadgetType_Button : DessinerBouton(*objet)
EndSelect
EndIf
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirCouleurGadget(*objet.sGadget, TypeCouleur)
Protected resultat
With *objet
; Code
Select TypeCouleur
Case #PB_Gadget_BackColor
resultat = \couleurfond
Case #PB_Gadget_FrontColor
resultat = \couleurpremierplan
Case #PB_Gadget_LineColor
resultat = \couleurbord
EndSelect
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonDefinirCouleurGadget(*objet.sGadget, TypeCouleur, Couleur)
With *objet
If \type
Select TypeCouleur
Case #PB_Gadget_BackColor
\couleurfond = Couleur
Case #PB_Gadget_FrontColor
\couleurpremierplan = Couleur
Case #PB_Gadget_LineColor
\couleurbord = Couleur
EndSelect
Select \type
Case #PB_GadgetType_Button : DessinerBouton(*objet)
EndSelect
EndIf
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirPoliceGadget(*objet.sGadget)
Protected resultat
With *objet
resultat = \hPolice
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonDefinirPoliceGadget(*objet.sGadget, hPolice)
With *objet
If \type
If hPolice
\hPolice = hPolice
Else
\hPolice = #PB_Default
EndIf
Select \type
Case #PB_GadgetType_Button : DessinerBouton(*objet)
EndSelect
EndIf
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonRedimensionnerGadget(*objet.sGadget, x.i, y.i, largeur.i, hauteur.i)
With *objet
If \type
If x <> #PB_Ignore
\x = x
EndIf
If y <> #PB_Ignore
\y = y
EndIf
If largeur <> #PB_Ignore
\dx = largeur
EndIf
If hauteur <> #PB_Ignore
\dy = hauteur
EndIf
Select \type
Case #PB_GadgetType_Button
ResizeGadget(\id, \x, \y, \dx, \dy)
DessinerBouton(*objet)
EndSelect
EndIf
EndWith
EndProcedure
Procedure MonCacherGadget(*objet.sgadget, Etat)
With *objet
If \type
\etat = Etat
If IsGadget(\id)
HideGadget(\id, \etat)
EndIf
EndIf
EndWith
EndProcedure
Procedure MonDesactiverGadget(*objet.sgadget, Etat)
With *objet
If \type
\etat = Etat
If IsGadget(\id)
DisableGadget(\id, \etat)
EndIf
EndIf
EndWith
EndProcedure
Procedure MonGadgetX(*objet.sgadget)
Protected resultat
With *objet
resultat = GadgetX(\id)
EndWith
ProcedureReturn resultat
EndProcedure
Procedure MonGadgetY(*objet.sgadget)
Protected resultat
With *objet
resultat = GadgetY(\id)
EndWith
ProcedureReturn resultat
EndProcedure
Procedure MonLongueurGadget(*objet.sgadget)
Protected resultat
With *objet
resultat = GadgetWidth(\id)
EndWith
ProcedureReturn resultat
EndProcedure
Procedure MonHauteurGadget(*objet.sgadget)
Protected resultat
With *objet
resultat = GadgetHeight(\id)
EndWith
ProcedureReturn resultat
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonObtenirAttributGadget(*objet.sGadget, Attribut)
Protected resultat
With *objet
resultat = GetGadgetAttribute(\id, Attribut)
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure MonDefinirAttributGadget(*objet.sGadget, Attribut, Valeur)
Protected resultat
With *objet
resultat = SetGadgetAttribute(\id, Attribut, Valeur)
EndWith
EndProcedure
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- Gestion des données
DataSection
tvGadget:
Data.i @MonObtenirID()
Data.i @MonObtenirGestionnaire()
Data.i @MonObtenirType()
Data.i @MonLibererGadget()
Data.i @MonObtenirEtatGadget()
Data.i @MonDefinirEtatGadget()
Data.i @MonObtenirTexteGadget()
Data.i @MonDefinirTexteGadget()
Data.i @MonObtenirCouleurGadget()
Data.i @MonDefinirCouleurGadget()
Data.i @MonObtenirPoliceGadget()
Data.i @MonDefinirPoliceGadget()
Data.i @MonRedimensionnerGadget()
Data.i @MonCacherGadget()
Data.i @MonDesactiverGadget()
Data.i @MonGadgetX()
Data.i @MonGadgetY()
Data.i @MonLongueurGadget()
Data.i @MonHauteurGadget()
Data.i @MonObtenirAttributGadget()
Data.i @MonDefinirAttributGadget()
EndDataSection
; Init Vide
Global Vide.sGadget
With Vide
\tv = ?tvGadget
\id = -1
EndWith
; -------------------------------------------------------------------------------------
Procedure NouvelleDonnee(id)
Protected *nouveau.sGadget, cle.s
cle = "ID-" + Str(id)
*nouveau = AddMapElement(MesDonneesGadget(), cle)
If *nouveau
*nouveau\tv = ?tvGadget
EndIf
ProcedureReturn *nouveau
EndProcedure
; -------------------------------------------------------------------------------------
Procedure LibererDonnees(id)
Protected resultat, cle.s
cle = "ID-" + Str(id)
If FindMapElement(MesDonneesGadget(), cle)
DeleteMapElement(MesDonneesGadget())
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;-- Fonctions Internes
Procedure BoiteDessinTexte(x, y, dx, dy, texte.s, drapeaux)
Protected est_multiligne, est_gauche, est_droite
Protected largeur_texte, hauteur_texte
Protected texte_x, texte_y
Protected lignes , ligne_texte.s, ligne_texte1.s, debut, quantite
est_multiligne = drapeaux & #PB_Button_MultiLine
est_gauche = drapeaux & #PB_Button_Left
est_droite = drapeaux & #PB_Button_Right
largeur_texte = VectorTextWidth(texte)
hauteur_texte = VectorTextHeight(texte)
If Not est_multiligne
If est_gauche
texte_x = 6
texte_y = dy / 2 - hauteur_texte / 2
ElseIf est_droite
texte_x = dx - largeur_texte - 6
texte_y = dy / 2 - hauteur_texte / 2
Else
texte_x = dx / 2 - largeur_texte / 2
texte_y = dy / 2 - hauteur_texte / 2
EndIf
MovePathCursor(x + texte_x, y + texte_y)
DrawVectorText(texte)
ProcedureReturn 1
EndIf
lignes = largeur_texte / dx
debut = 1
texte_y = (dy / 2 - hauteur_texte / 2) - (hauteur_texte / 2 * lignes)
quantite = CountString(texte, " ") + 1
Repeat
ligne_texte = StringField(texte, debut, " ") + " "
Repeat
debut + 1
ligne_texte1 = StringField(texte, debut, " ")
If VectorTextWidth(ligne_texte + ligne_texte1) < dx - 12
ligne_texte + ligne_texte1 + " "
Else
Break
EndIf
Until debut > quantite
ligne_texte = Trim(ligne_texte)
If est_gauche
texte_x = 6
ElseIf est_droite
texte_x = dx - VectorTextWidth(ligne_texte) - 6
Else
texte_x = dx / 2 - VectorTextWidth(ligne_texte) / 2
EndIf
MovePathCursor(x + texte_x, y + texte_y)
DrawVectorText(ligne_texte)
texte_y + hauteur_texte
Until debut > quantite
EndProcedure
; -------------------------------------------------------------------------------------
Procedure DessinerBouton(*objet.sGadget)
Protected couleurfond, couleurfond2, couleurbord2
Protected dx, dy
Protected largeur_texte, hauteur_texte
Protected texte_x, texte_y
With *objet
If \etatCouleur = #CouleurBoutonEtatPresse Or \etat = 1
couleurfond = RGBA(Red(\couleurfond) * 85 / 100, Green(\couleurfond) * 85 / 100, Blue(\couleurfond) * 85 / 100, 255)
couleurbord2 = $FFC0C0C0
ElseIf \etatCouleur = #CouleurBoutonEtatSurvole
couleurfond = RGBA(Red(\couleurfond) * 95 / 100, Green(\couleurfond) * 95 / 100, Blue(\couleurfond) * 95 / 100, 255)
couleurbord2 = $FF000000
Else
couleurfond = \couleurfond
couleurbord2 = $FF000000
EndIf
StartVectorDrawing(CanvasVectorOutput(\id))
If \dx > 2 And \dy > 2
If \style
; Style Windows 8
AddPathBox(0, 0, \dx, \dy) : VectorSourceColor(\couleurbord) : StrokePath(2)
AddPathBox(1, 1, \dx - 2, \dy - 2) : VectorSourceColor(couleurfond) : FillPath()
Else
; Style Windows 7
couleurfond2 = RGBA(Red(couleurfond) * 95 / 100, Green(couleurfond) * 95 / 100, Blue(couleurfond) * 95 / 100, 255)
AddPathBox(0, 0, \dx, \dy) : VectorSourceColor(\couleurbord) : StrokePath(2)
AddPathBox(1, 1, \dx - 2, \dy - 2) : VectorSourceColor(couleurbord2) : FillPath()
dx = \dx - 4
dy = (\dy - 4) / 2
AddPathBox(2, 2, dx, dy) : VectorSourceColor(couleurfond) : FillPath()
AddPathBox(2, 2 + dy, dx, dy) : VectorSourceColor(couleurfond2) : FillPath()
AddPathLine(0, 0) : VectorSourceColor($FF000000)
AddPathLine(\dx - 1, 0) : VectorSourceColor($FF000000)
AddPathLine(0 ,\dy - 1) : VectorSourceColor($FF000000)
AddPathLine(\dx - 1,\dy - 1) : VectorSourceColor($FF000000)
AddPathLine(1, 1) : VectorSourceColor(\couleurbord)
AddPathLine(\dx - 2, 1) : VectorSourceColor(\couleurbord)
AddPathLine(1 ,\dy - 2) : VectorSourceColor(\couleurbord)
AddPathLine(\dx - 2,\dy - 2) : VectorSourceColor(\couleurbord)
AddPathLine(2, 2) : VectorSourceColor(couleurbord2)
AddPathLine(\dx - 3, 2) : VectorSourceColor(couleurbord2)
AddPathLine(2 ,\dy - 3) : VectorSourceColor(couleurbord2)
AddPathLine(\dx - 3,\dy - 3) : VectorSourceColor(couleurbord2)
EndIf
If \hPolice
VectorFont(\hPolice)
EndIf
VectorSourceColor(\couleurpremierplan)
BoiteDessinTexte(0, 0, \dx, \dy, \texte, \drapeaux)
Else
AddPathBox(0, 0, \dx, \dy)
VectorSourceColor($FF808080)
FillPath()
EndIf
StopVectorDrawing()
EndWith
EndProcedure
; -------------------------------------------------------------------------------------
Procedure GestionEvenements_Bouton()
Protected id, *objet.sGadget, cle.s
id = EventGadget()
If Not IsGadget(id)
ProcedureReturn 0
EndIf
cle = "ID-" + Str(id)
*objet = FindMapElement(MesDonneesGadget(), cle)
If *objet
With *objet
Select EventType()
Case #PB_EventType_MouseEnter
\etatCouleur = #CouleurBoutonEtatSurvole
DessinerBouton(*objet)
Case #PB_EventType_MouseLeave
\etatCouleur = #CouleurBoutonEtatDefaut
DessinerBouton(*objet)
Case #PB_EventType_LeftButtonDown
\etatCouleur = #CouleurBoutonEtatPresse
DessinerBouton(*objet)
Case #PB_EventType_LeftButtonUp
If \etatCouleur = #CouleurBoutonEtatPresse
\etatCouleur = #CouleurBoutonEtatSurvole
Else
\etatCouleur = #CouleurBoutonEtatDefaut
EndIf
DessinerBouton(*objet)
Case #PB_EventType_LeftClick
If \drapeaux & #PB_Button_Toggle = #PB_Button_Toggle
If \etat
\etat = 0
Else
\etat = 1
EndIf
DessinerBouton(*objet)
EndIf
EndSelect
EndWith
EndIf
EndProcedure
; *************************************************************************************
;-- Fonctions Publiques
Procedure GadgetCouleurBouton(id, x, y, dx, dy, texte.s, drapeaux = #PB_Button_Default)
Protected resultat, nr, *objet.sGadget
Repeat
; Créer Gadget
resultat = CanvasGadget(id, x, y , dx, dy)
If resultat = 0
*objet = @Vide
Break
EndIf
If id = #PB_Any
nr = resultat
Else
nr = id
EndIf
; Créer vos données perso
*objet = NouvelleDonnee(nr)
If Not *objet
FreeGadget(nr)
*objet = @Vide
Break
EndIf
; Attribuer vos données perso
With *objet
\id = nr
\type = #PB_GadgetType_Button
\x = x
\y = y
\dx = dx
\dy = dy
\texte = texte
\drapeaux = drapeaux
\etat = 0
\etatCouleur = #CouleurBoutonEtatDefaut
\hPolice = GetGadgetFont(#PB_Default)
\couleurpremierplan = $FF000000
\couleurfond = $FFF0F0F0
\couleurbord = $FF808080
If OSVersion() >= #PB_OS_Windows_10 And OSVersion() <= #PB_OS_Windows_Future
\style = 1
Else
\style = 0
EndIf
EndWith
; Dessiner
DessinerBouton(*objet)
; définir Gestion événements
BindGadgetEvent(nr, @GestionEvenements_Bouton(), #PB_All)
Until #True
ProcedureReturn *objet
EndProcedure
EndModule
;- Fin Module
; ***************************************************************************************
;- Test
CompilerIf #PB_Compiler_IsMainFile
;- <constantes
Enumeration ; Window ID
#Window
EndEnumeration
Enumeration ; Menu ID
#Menu
EndEnumeration
Enumeration ; MenuItem ID
#Menu_quitter
EndEnumeration
Enumeration ; Statusbar ID
#Statusbar
EndEnumeration
Enumeration ; Gadget ID
EndEnumeration
; ***************************************************************************************
;- Variables Globales
UseModule MesVectorGadgets
Global quitter = 0
Global.iGadget *btn0, *btn1, *btn2
;- Fenêtres
style = #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget | #PB_Window_SizeGadget
If OpenWindow(#Window, #PB_Ignore, #PB_Ignore, 500, 400, "Fenêtre", style)
; Menu
If CreateMenu(#Menu, WindowID(#Window))
MenuTitle("&Fichier")
MenuItem(#Menu_quitter, "&Quitter")
EndIf
; Statusbar
CreateStatusBar(#Statusbar, WindowID(#Window))
; Gadgets
LoadFont(0, "Arial", 16)
*btn0 = GadgetCouleurBouton(0, 10 ,10, 200, 40, "Bouton 1 (aligné à gauche)", #PB_Button_Left)
*btn1 = GadgetCouleurBouton(1, 10 ,60, 200, 40, "Bouton 2", #PB_Button_MultiLine)
*btn1\SetGadgetColor(#PB_Gadget_BackColor, $FFFF4040)
*btn1\SetGadgetColor(#PB_Gadget_FrontColor, $FFFFFFFF)
*btn1\SetGadgetFont(FontID(0))
*btn2 = GadgetCouleurBouton(2, 10, 180, 200, 40, "Bouton 3 (aligné à droite)", #PB_Button_Toggle | #PB_Button_Right)
*btn2\SetGadgetColor(#PB_Gadget_BackColor, $FF8080FF)
*btn1\ResizeGadget(10, 80, 300, 80)
*btn1\SetGadgetText("Bonjour monde cruel! Multiligne (centré par défaut)")
Debug "Bouton 0"
Debug *btn0\GetID()
Debug *btn0\GetHandle()
Debug *btn0\GetGadgetText()
Debug "--------------------"
Debug "Bouton 1"
Debug *btn1\GetID()
Debug *btn1\GetHandle()
Debug *btn1\GetGadgetText()
Debug "--------------------"
Debug "Bouton 2"
Debug *btn2\GetID()
Debug *btn2\GetHandle()
Debug *btn2\GetGadgetText()
Debug "--------------------"
;-- Boucle événementielle
Repeat
evenement = WaitWindowEvent()
Select evenement
Case #PB_Event_Menu
Select menu
Case #Menu_quitter
quitter = 1
EndSelect
Case #PB_Event_Gadget
Select EventGadget()
Case 0
Select EventType()
Case #PB_EventType_LeftClick
Debug "Bouton 1 Cliqué"
Case #PB_EventType_LeftButtonDown
Debug "Bouton 1 Pressé"
Case #PB_EventType_LeftButtonUp
Debug "Bouton 1 Relâché"
EndSelect
Case 1
If EventType() = #PB_EventType_LeftClick
Debug "Bouton 2"
EndIf
Case 2
If EventType() = #PB_EventType_LeftClick
Debug "Bouton 3: Etat " + Str(*btn2\GetGadgetState())
EndIf
EndSelect
Case #PB_Event_CloseWindow
quitter = 1
EndSelect
Until quitter
EndIf
CloseWindow(#Window)
CompilerEndIf