'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
' Module RESIZER userform version basic
'version avec api déclarées
'release 2020 for XLD
'****************************************************************************************************
Option Explicit
#If VBA7 Then
#If Win64 Then
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal Hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" ( _
ByVal Hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function ShowWindow Lib "user32" ( _
ByVal Hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Dim Hwnd As LongPtr
#Else
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" ( _
ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long
Dim Hwnd As Long
#End If
Public OldW As Double
Public OldH As Double
Sub trois_boutons(usf) 'ajoute les 3 boutons et le resize dynamique à l'userform
Hwnd = FindWindow(vbNullString, usf.Caption)
SetWindowLongPtr Hwnd, -16, &H94CF0080 'api SetWindowLongA
End Sub
Sub NoTitleBar(usf) 'supprime la barre de titre( rempli absolument tout l'ecran
Hwnd = FindWindow(vbNullString, usf.Caption)
SetWindowLongPtr Hwnd, -16, &H140F0101
End Sub
Sub SameSizeApplication(usf) 'taille et position identique à l'application
With Application
usf.Move .Left, .Top, .Width, .Height
End With
End Sub
Sub UsfFullScreen(usf) 'met le userform en plein ecran
Hwnd = FindWindow(vbNullString, usf.Caption)
ShowWindow Hwnd, 3
End Sub
Function memoControlSize(usf) 'on memorise dans le tag des controls leur position et dimension
Dim CtrL
OldW = usf.Width
OldH = usf.Height
For Each CtrL In usf.Controls
CtrL.Tag = CtrL.Left & ";" & CtrL.Top & ";" & CtrL.Width & ";" & CtrL.Height
On Error Resume Next
CtrL.Tag = CtrL.Tag & ";" & CtrL.Font.Size
CtrL.Tag = CtrL.Tag & ";"
Err.Clear: On Error GoTo 0
If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
CtrL.Tag = CtrL.Tag & ";" & Replace(CtrL.ColumnWidths, ";", "|")
End If
CtrL.Tag = CtrL.Tag & ";"
DoEvents
Next
memoControlSize = OldW > 0
End Function
Sub resiZer(usf)
Dim newW#, NewH#, t, cw$, tc, CtrL, i&
Do While OldW = 0: DoEvents: Loop
newW = usf.Width / OldW
NewH = usf.Height / OldH
For Each CtrL In usf.Controls
t = Split(CtrL.Tag, ";")
CtrL.Move t(0) * newW, t(1) * NewH, t(2) * newW, t(3) * NewH
If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
If CtrL.ColumnWidths = "" Then
cw = Application.Rept("80 ", CtrL.ColumnCount)
cw = Replace(cw, " ", "|")
t(6) = cw
'Else: cw = CtrL.ColumnWidths
End If
tc = Split(t(6), "|")
For i = 0 To UBound(tc): tc(i) = Int(Val(tc(i)) * Application.Min(newW, NewH)): Next
CtrL.ColumnWidths = Join(tc, " pt;")
'MsgBox CtrL.ColumnWidths
End If
On Error Resume Next
CtrL.Font.Size = t(4) * Application.Min(newW, NewH)
Err.Clear: On Error GoTo 0
Next
End Sub