Redimensionnement de l'userform (pc portable)

**fidecourt** · 11/11/2016, 17h41

bonjour Patrick et à tous les autres membres

J'ai lu cette discussion.

j'ai utilisé ton exemple pour le redimensionnement d'un formulaire en fonction des différents écrans d'ordi, et c'est super

j'ai un fichier excel avec une dizaine de userforms, j'aurai voulu savoir comment passer toutes les instructions une seule et unique fois quelque soit le formulaire utilisé pour éviter de reprendre tout le code dans chaque formulaire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Dim cl As New allinOne
Private Sub UserForm_Resize()
cl.sresize Me     'lancement du redimensionnement
End Sub
Private Sub UserForm_Activate()
'choisir ci-dessous la forme de visualisation des formulaires et bloquer les autres (mise en commentaires)
cl.in_all_screen Me                            'on garde la caption et la barre des tache
'cl.in_all_screen Me, False                    'on supprime la caption mais on garde la barre des tache
'cl.in_all_screen Me, False, False             'on supprime la caption et la barre des tache
'cl.in_all_screen Me, , False                  'on garde la caption mais on supprime la barre des tache
End Sub
Private Sub UserForm_Initialize()
 
cl.init_usf Me 'initialisation du redimensionnement du formulaire pour l'écran de l'ordi
 
'suite du code....
 
End Sub

je suppose qu'il y a une méthode pour déclarer tout ceci qu'une fois mais je ne suis pas assez calée en code pour connaître cela

merci par avance pour votre aide

merci Patrick pour ta réactivité.
je me sens un peu "bêtasse" mais je ne vois pas de pièce jointe avec le code, uniquement l'animation qui s'ouvre lorsque l'on clique sur le lien
je me plante ou bien y-a-t-il autre chose ?

A+

**patricktoulon** · 11/11/2016, 18h13

re

il fallait remonter plus haut dans la discution

toujours est il que pour que cela agisse sur tout tes userform

il faut lancer la classe a chaque activate d'un usf

elle fonctionnera pour tous
met cela dans un nouveau module classe"Classe1"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public WithEvents BOUTON As MSForms.CommandButton
Public WithEvents forme As UserForm
Public WithEvents framme As MSForms.Frame
#If VBA6 Then
Private Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function FWA Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ShowWindow Lib "User32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function SWL Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#Else
Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe Function FWA Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare PtrSafe Function ShowWindow Lib "User32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function SWL Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
Private Const SM_CXSCREEN = 0    'Screen width
Private Const SM_CYSCREEN = 1    'Screen height
Private Const LOGPIXELSX = 88    'Pixels/inch in X
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'A point is defined as 1/72 inches
Private Const POINTS_PER_INCH As Long = 72
 
Dim bout(100) As New allinOne
Dim fram(100) As New allinOne
Dim RW As Single, RH As Single
'The width of the screen, in pixels
Public Function ScreenWidth() As Long
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function
'The height of the screen, in pixels
Public Function ScreenHeight() As Long
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Function
Function HeightBarre()
    Dim R As RECT, rectangle As Long, handletask As Long
    handletask = FWA("Shell_TrayWnd", "")    'on capte le handle de la taskbar
    rectangle = GetWindowRect(handletask, R)    'on créé un rectangle en memoire  correspondant au coordonées de la taskbar
    HeightBarre = ScreenHeight - R.Top
End Function
'The size of a pixel, in points
Public Function PointsPerPixel() As Double
    Dim hDC As Long
    Dim lDotsPerInch As Long
    hDC = GetDC(0)
    lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
    ReleaseDC 0, hDC
End Function
Function heightborder()
    heightborder = GetSystemMetrics(8)
End Function
'Ensuite Sur l'initialisation du formulaire
Sub init_usf(usf)
    RW = usf.Width
    RH = usf.Height
    Set bout(0).forme = usf
    For Each ctl In usf.Controls
        ctl.Tag = Round(ctl.Left, 2) & ":" & Round(ctl.Top, 2) & ":" & Round(ctl.Width, 2) & ":" & Round(ctl.Height, 2)
        If TypeName(ctl) <> "ScrollBar" And TypeName(ctl) <> "SpinButton" Then ctl.Tag = ctl.Tag & ":" & ctl.Font.Size
 
     If TypeName(ctl) = "Frame" Then
    a = a + 1
    Set fram(i).framme = usf.Controls(ctl.Name)
    End If
    If TypeName(ctl) = "CommandButton" Then
    i = i + 1
        ctl.Tag = ctl.Tag & ":" & ctl.BackColor
    Set bout(i).BOUTON = usf.Controls(ctl.Name)
 
    End If
    Next
End Sub
Sub in_all_screen(usf, Optional captions As Boolean = True, Optional tasks As Boolean = True)
    Dim handle As Long
    handle = FWA(vbNullString, usf.Caption)
    'si captions = False on la retire
    If captions = False Then SWL handle, -16, &H94080080: SWL handle, -20, 0: DrawMenuBar handle
    'si task=true on garde la taskbar
    Select Case tasks
    Case True
        'Calcule le rapport de l'UserForm et la taille de l'écranusf.Width = ScreenWidth * PointsPerPixel - heightborder
        usf.Height = (ScreenHeight * PointsPerPixel) - (HeightBarre * PointsPerPixel) - (heightborder * 2)
        usf.Width = (ScreenWidth * PointsPerPixel) - IIf(captions, (heightborder * 2), 0)
        usf.Top = 0: usf.Left = 1
    Case False
        ShowWindow handle, 3
    End Select
End Sub
Sub sresize(usf)
    Dim RW2, RH2
    RW2 = usf.Width / RW
    RH2 = usf.Height / RH
    For Each ctl In usf.Controls
        dims = Split(ctl.Tag, ":")
        ctl.Move dims(0) * RW2, dims(1) * RH2, dims(2) * RW2, dims(3) * RH2
        If TypeName(ctl) <> "ScrollBar" And TypeName(ctl) <> "SpinButton" Then ctl.Font.Size = dims(4) * RW2
    Next
End Sub
' ICI L EVENEMENT  MOUSE MOVE DE SUBSTITUTION
Private Sub BOUTON_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
BOUTON.BackColor = vbRed
End Sub
Private Sub forme_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
For Each ctrl In forme.Controls
If TypeName(ctrl) = "CommandButton" Then
ctrl.BackColor = Split(ctrl.Tag, ":")(5)
End If
Next
End Sub
Private Sub framme_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
For Each ctrl In framme.Parent.Controls
If TypeName(ctrl) = "CommandButton" Then
ctrl.BackColor = Split(ctrl.Tag, ":")(5)
End If
Next
End Sub

dans tout tes userforms maintenant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
dim clas new classe1
Private Sub UserForm_Activate()
cl.init_usf Me
'fait ton choix et debloque la bonne ligne et bloque toute les autres
'cl.in_all_screen Me                            'on garde la caption et la barre des tache
cl.in_all_screen Me, False                      'on vire la caption mais on garde la barre des tache
'cl.in_all_screen Me, False, False               'on vire la caption et la barre des tache
'cl.in_all_screen Me, , False                    'on garde la caption mais on vire la barre des tache
 
End Sub

voila

**fidecourt** · 12/11/2016, 09h44

Merci Patrick pour ton aide et tes explications.
voici du code bien utile pour les applications utilisant les userforms
trop bien avec ton exemple
bonne journée

**patricktoulon** · 12/11/2016, 11h43

correstion!!

change ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Dim bout(100) As New allinOne
Dim fram(100) As New allinOne

pour cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Dim bout(100) As New Classe1
Dim fram(100) As New Classe1

Redimensionnement de l'userform (pc portable)

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager