cathodique
XLDnaute Barbatruc
Bonjour la communauté,
J'ai besoin de votre aide. Merci à celles et ceux qui ont Windows 10 64 bits et Excel 2019 64 bits de tester l'affichage en plein écran d'un userform.
La procédure ci-dessous avait été proposée, si mes souvenirs sont bons par @patricktoulon ,
je n'ai modifié que la partie haute mais ne fonctionne pas sous: Windows 10 64 bits et Excel 2019 64 bits.
Auriez-vous une solution à me proposer?
J'ai besoin de votre aide. Merci à celles et ceux qui ont Windows 10 64 bits et Excel 2019 64 bits de tester l'affichage en plein écran d'un userform.
La procédure ci-dessous avait été proposée, si mes souvenirs sont bons par @patricktoulon ,
je n'ai modifié que la partie haute mais ne fonctionne pas sous: Windows 10 64 bits et Excel 2019 64 bits.
Auriez-vous une solution à me proposer?
VB:
Option Explicit
#If VBA7 Then
#If Win64 Then
Public Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function GetWindowLongA Lib "user32" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
#Else
Public Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function GetWindowLongA Lib "user32" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
#End If
#Else
' Pour Excel 2007 ou antérieur (VBA6)
Public Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If
Public Sub SameSizeApplication(Usf As Object) 'utilisé
Dim ctl As Control, ratioW#, ratioH#, tbCw, i&
With Application: ratioW = .UsableWidth / Usf.Width: ratioH = .Height / Usf.Height: End With
Usf.Move 0, 0, Usf.Width * ratioW, Usf.Height * ratioH
For Each ctl In Usf.Controls
ctl.Move ctl.Left * ratioW, ctl.Top * ratioH, ctl.Width * ratioW, ctl.Height * ratioH
On Error Resume Next
ctl.Font.Size = Round(ctl.Font.Size * Application.Min(ratioH, ratioW))
On Error GoTo 0
If TypeName(ctl) = "ListBox" Or TypeOf ctl Is ListBox Then
If ctl.ColumnWidths <> "" Then
tbCw = Split(Replace(ctl.ColumnWidths, " pt", ""), ";")
For i = LBound(tbCw) To UBound(tbCw): tbCw(i) = val(tbCw(i)) * ratioW: Next
ctl.ColumnWidths = Join(tbCw, ";")
End If
End If
Next
End Sub
Public Sub ShowFullScreenUserForm(Usf As Object) ''ok'utilisé
Dim hWnd As Long
' Ajuster les contrôles en fonction du nouveau format
SameSizeApplication Usf
hWnd = FindWindowA(vbNullString, Usf.Caption) 'plante ici
' Mettre le UserForm en plein écran sans barre de titre
SetWindowLongA hWnd, -16, &H94080080
' ShowWindow hwnd, 3
End Sub
