cathodique
XLDnaute Barbatruc
Bonjour,
Cette discussion est une suite de ma précédente
Il s'agit de 2 codes proposés par @patricktoulon (que je salue
Dans la précédente discussion, il s'agissait d'ôter la barre de titre d'une userform, avec affichage en plein écran du formulaire et de l'application Excel.
Patrick m'a montré comme y arriver avec et sans APIs.
J'avais déjà dans ma tirelire un code de Patrick pour la mise en plein écran d'une userform.
J'avais cru qu'il me suffirait d'appeler les procédures l'une après l'autre pour avoir le résultat escompté:
Un formulaire en plein écran avec les différents contrôles à l'échelle et sans la barre de titre.
Je me suis lourdement trompé. Voci ce que j'ai fait:
Le formulaire s'affiche avec le barre de titre et n'occupe pas toute la hauteur de l'écran.
Merci pour votre aide.
Bon week-end
Cette discussion est une suite de ma précédente
Il s'agit de 2 codes proposés par @patricktoulon (que je salue
Dans la précédente discussion, il s'agissait d'ôter la barre de titre d'une userform, avec affichage en plein écran du formulaire et de l'application Excel.
Patrick m'a montré comme y arriver avec et sans APIs.
J'avais déjà dans ma tirelire un code de Patrick pour la mise en plein écran d'une userform.
J'avais cru qu'il me suffirait d'appeler les procédures l'une après l'autre pour avoir le résultat escompté:
Un formulaire en plein écran avec les différents contrôles à l'échelle et sans la barre de titre.
Je me suis lourdement trompé. Voci ce que j'ai fait:
VB:
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)
Dim hwnd As Long
hwnd = FindWindowA(vbNullString, Usf.Caption)
' Mettre le UserForm en plein écran sans barre de titre
SetWindowLongA hwnd, -16, &H94080080
ShowWindow hwnd, 3
' Ajuster les contrôles en fonction du nouveau format
SameSizeApplication Usf
End SubMerci pour votre aide.
Bon week-end