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
| Option Explicit
'
'Ce programme donne une form plein écran quelque soient la résolution
'et la taille de l'écran, grâce à l'utilisation des fonctions API.
'La bordure peut être facilement modifiée si besoin.
'
'
'Fonctions API
Private Declare Function GetSystemMenu Lib "User32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "User32" (ByVal hMenu As Long, ByVal iditem As Long, ByVal wflags As Long) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "User32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function IsIconic Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function IsZoomed Lib "User32" (ByVal hWnd As Long) As Long 'non utilisée ici
Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()
'
Private Const SW_MAXIMIZE = 3 'constantes pour la fonction
Private Const SW_MINIMIZE As Long = 6 'ShowWindow
'
Private Const GWL_STYLE As Long = (-16) 'The offset of a window's style
Private Const WS_MINIMIZEBOX = &H20000 'Style to add a Minimize box on the title bar
Private Const WS_CAPTION As Long = &HC00000 'Style to add a titlebar
'
Private Const SC_MOVE = &HF010 'constantes
Private Const SC_CLOSE = &HF060 'pour la fonction
Private Const MF_BYCOMMAND = &H0 'DeleteMenu
'
Private Const WM_NCLBUTTONDOWN = &HA1 'constantes pour
Private Const HTCAPTION = 2 'déplacement form sans titre
'
Dim hWnd As Long 'le handle de la form
Dim wInit As Long, hInit As Long 'ses dimensions d'origine
Dim FormInit As Boolean 'définit l'étape d'initialisation de la form
Dim FormSansTitre As Boolean 'définit l'étape d'enlèvement du titre
Dim FormST As Boolean 'definit l'état de la form
'
Private Sub UserForm_Activate()
ShowWindow hWnd, SW_MAXIMIZE 'on veut maximiser la form au démarrage,
'ce qui est en fait la raison d'être de ce code...
End Sub
Private Sub UserForm_Initialize()
Dim iStyle As Long, hMenu As Long
hWnd = FindWindow(vbNullString, Me.Caption) 'le handle de la form
hMenu = GetSystemMenu(hWnd, 0) 'le handle du system menu
iStyle = GetWindowLong(hWnd, GWL_STYLE) 'trouve le style du system menu
iStyle = iStyle Or WS_MINIMIZEBOX 'ajoute le bouton mimimise
SetWindowLong hWnd, GWL_STYLE, iStyle 'applique le nouveau style
DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND 'désactive le bouton supprime
wInit = Me.Width: hInit = Me.Height
FormInit = True
FormSansTitre = True
iStyle = GetWindowLong(hWnd, GWL_STYLE) 'trouve le style du system menu
iStyle = iStyle And Not WS_CAPTION 'on ne veut pas de titre
SetWindowLong hWnd, GWL_STYLE, iStyle 'applique le nouveau style
DrawMenuBar hWnd
FormSansTitre = False
FormST = True
Dim j As Long
Dim F As Worksheet
Dim Ligne As Long
Dim Clear As Variant
End Sub
Private Sub UserForm_Resize()
Dim RW As Single, RH As Single
If IsIconic(hWnd) <> 0 Then Exit Sub 'la form est en icône:pas de redimensionnements!
If FormInit = False Then Exit Sub 'on ne doit exécuter les redimensionnements des contrôles qu'une fois au départ!
If FormSansTitre = True Then Exit Sub 'ne pas exécuter le resize au moment où on enlève le titre...
'rapports d'agrandissement
RW = Me.Width / wInit: RH = Me.Height / hInit
'redimensionnement et replacement de l'ensemble des contrôles voulus en fonction de l'écran
Dim Ctl As MSForms.Control
For Each Ctl In Me.Controls
'on a mis un tag pour les contrôles que l'on ne veut pas redimensionner
If Ctl.Tag = "" Then Ctl.Move Ctl.Left * RW, Ctl.Top * RH, Ctl.Width * RW, Ctl.Height * RH
If Not TypeOf Ctl Is Image Then 'ajouter si besoin les autres contrôles n'ayant pas de police
Ctl.Font.Size = Round(Ctl.Font.Size * RH) 'redim des polices
End If
Next
End Sub
'pour déplacer la form sans barre de titre avec bouton gauche souris
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
If FormST Then
Call ReleaseCapture
SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
Else
Call ReleaseCapture
End If
End If
End Sub |
