Option Explicit
'Ce programme montre comment adapter un Userform
'à la taille d'un ecran quelque soit la résolution
'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 CommandButton4_Click()
Unload Me
End Sub
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...
Dim hMenu As Long 'empêche le mouvement de la forme
hMenu = GetSystemMenu(hWnd, 0) 'le handle du system menu
DeleteMenu hMenu, SC_MOVE, MF_BYCOMMAND
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
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
End Sub
Private Sub UserForm_Resize()
Dim RW As Single, RH As Single
'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
Ctl.Move Ctl.Left * RW, Ctl.Top * RH, Ctl.Width * RW, Ctl.Height * RH
Ctl.Font.Size = Round(Ctl.Font.Size * RH) 'redim des polices
Next
End Sub