1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
| #If VBA7 Then
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare PtrSafe Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Private Const SC_CLOSE = &HF060&
Private Const MF_BYCOMMAND = &H0&
Dim hwnd As Long, Style As Long
Public Usf As Object
Private Nom As String
Public Dico As Object
Public TypeObjet As String
Public WithEvents Bouton As MSForms.CommandButton
Public WithEvents Text As MSForms.TextBox
Public WithEvents FRM As MSForms.Frame
Public WithEvents MultiPage As MSForms.MultiPage
Private Function NewControl(Controle As String, Page As Integer)
If Dico.EXISTS(Name) = True Then NewControl = Nothing: Exit Function
Select Case TypeObjet
Case "UserForm"
Set NewControl = Usf.Controls.Add(Controle)
Case "Frame"
Set NewControl = FRM.Controls.Add(Controle)
Case "MultiPage"
Set NewControl = MultiPage(Page).Add(Controle)
End Select
End Function
'Initialise la collection
Private Sub Class_Initialize()
Set Dico = CreateObject("Scripting.dictionary")
End Sub
Public Sub NewTxt(Name As String, TxtDefaut As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.Textbox.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
Dim cls As New Classe1
Set cls.Text = obj
Set cls.Usf = Usf
With cls.Text
.Name = Name
.Text = TxtDefaut
.Width = Width
.Height = Height
.Left = Left
.Top = Top
End With
Dico.Add Name, cls
Set cls = Nothing
End Sub
'permet de créer un UserForm
Private Sub NewUsf(Caption As String, Width As Double, Height As Double)
Set Usf2 = ThisWorkbook.VBProject.VBComponents.Add(3)
Nom = Usf2.Name
VBA.UserForms.Add (Nom)
Set Usf = UserForms(UserForms.Count - 1)
TypeObjet = "UserForm"
With Usf
.Caption = Caption
.Width = Width
.Height = Height
End With
End Sub
'Ouvre le UserForm
Public Sub Show()
NewUsf "toto", (120 * 2) + 100, (30 * 7) + 5 + (5 * 5)
NewFrme "Fram1", "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3
NewMulitPage "MulitPage1", "toto", (110 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, 7, 0, "Bouton 1", "Bouton 2", "Bouton 3", "Bouton 4", "Bouton 5", "Bouton 6", "Bouton 7"
For I = 1 To 7
Dico("MulitPage1").NewFrme "Fram" & I, "toto", (18 * 2) + 100, (30 * 7) + 3 + (5 * 5), 3, 3, I - 1
Dico("MulitPage1").Dico("Fram" & I).NewBouton "Bouton" & I, "Bouton " & I, 100, 30, 20, 30 * 5
Next
Usf_Initialize
Usf.Show
End Sub
Public Sub NewMulitPage(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Nb As Integer, Page As Integer, ParamArray Onglets())
Dim obj
Set obj = NewControl("forms.MultiPage.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
Dim cls As New Classe1
Set cls.Usf = Usf
Set cls.MultiPage = obj
n = cls.MultiPage.Pages.Count
n = Nb - n
For I = 1 To n
cls.MultiPage.Pages.Add
Next
For I = 0 To UBound(Onglets)
cls.MultiPage.Pages(I).Caption = CStr(Onglets(I))
Next
cls.TypeObjet = "MultiPage"
With cls.MultiPage
.Name = Name
'.Caption = Caption
.Width = Width
.Height = Height
.Left = Left
.Top = Top
End With
Dico.Add Name, cls
Set cls = Nothing
End Sub
Public Sub NewFrme(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.frame.1", Page)
If TypeName(obj) = "Nothing" Then Exit Sub
Dim cls As New Classe1
Set cls.Usf = Usf
Set cls.FRM = obj
cls.TypeObjet = "Frame"
With cls.FRM
.Name = Name
.Caption = Caption
.Width = Width
.Height = Height
.Left = Left
.Top = Top
End With
Dico.Add Name, cls
Set cls = Nothing
End Sub
'Permet d'ajouter un bouton
Public Sub NewBouton(Name As String, Caption As String, Width As Double, Height As Double, Left As Double, Top As Double, Optional Page As Integer = 0)
Dim obj
Set obj = NewControl("forms.CommandButton.1", Page)
If obj = True Then Exit Sub
Dim cls As New Classe1
Set cls.Usf = Usf
Set cls.Bouton = obj
With cls.Bouton
.Name = Name
.Caption = Caption
.Width = Width
.Height = Height
.Left = Left
.Top = Top
End With
Dico.Add Name, cls
Set cls = Nothing
End Sub
'permet de supprimer le UserForm
Private Sub Class_Terminate()
Dim I As Integer
Set Dico = Nothing
If Nom <> "" Then
Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
ThisWorkbook.VBProject.VBComponents.Remove VBComp
End If
End Sub
'L'evennement Click Bouton7 ferme le UserForm
Private Sub Bouton_Click()
Select Case Bouton.Name
Case "Bouton7"
Unload Usf
Case Else
MsgBox Bouton.Name
End Select
End Sub
'code se déclenchant à l'ouverture de Userform1
Private Sub Usf_Initialize()
Dim hSysMenu As Long
Dim MeHwnd As Long
MeHwnd = FindWindowA(vbNullString, Usf.Caption)
If MeHwnd > 0 Then
hSysMenu = GetSystemMenu(MeHwnd, False)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
Else
MsgBox "Handle de " & Usf.Caption & " Introuvable", vbCritical
End If
End Sub |
Partager