Problemi Userform a tutto schermo

Question

Problemi Userform a tutto schermo

Anonimo

Buongiorno,

eccomi qui con l'ultima domanda per il programma che vi ho tanto assillato.

Da anni cerco una soluzione in rete per l'ingrandimento a tutto schermo della userform ed i suoi oggetti. Sono riuscito a trovare come aggiungere il pulsante "Riduci a Icona" quello "Ingrandisci" ma non sono mai riuscito a trovare un codice che realmente adatta lo schermo a tutti i tipi di risoluzione.

Vi posto tre screenshot con le varie risoluzioni degli schermi ed il codice sperando vivamente in un vostro aiuto.

Purtroppo questo programma verrà usato su parecchi computer diversi ed il risultato è realmente brutto specie se lancio il file con : userform.show e la userform con: ShowWindow hwnd, SW_MAXIMIZE

Grazie a tutti per una possibile soluzione

Saluti

Giuseppe

Schermo del computer in ufficio risoluzione: 1280 x 960

Schermo del computer in plancia risoluzione: 1600 x 1200

Schermo del computer in cabina risoluzione: 1440 x 900

Come vedete, l'ultimo schermo non dimensiona tutti gli oggetto a riempire il monitor.

Ecco il primo codice inserito in un modulo standard nominato FormFunctions:

Option Explicit

Option Compare Text

Private Const C_USERFORM_CLASSNAME = "ThunderDFrame"

Private Const C_EXCEL_APP_CLASSNAME = "XLMain"

Private Const C_EXCEL_DESK_CLASSNAME = "XLDesk"

Private Const C_EXCEL_WINDOW_CLASSNAME = "Excel7"

Private Const MF_BYPOSITION = &H400

Private Const MF_REMOVE = &H1000

Private Const MF_ENABLED = &H0&

Private Const MF_DISABLED = &H2&

Private Const MF_GRAYED = &H1&

Private Const GWL_EXSTYLE = (-20)

Private Const GWL_STYLE = (-16)

Private Const GWL_HWNDPARENT = (-8)

Private Const WS_CAPTION = &HC00000

Private Const WS_SYSMENU = &H80000

Private Const WS_EX_LAYERED = &H80000

Private Const LWA_ALPHA = &H2&

Private Const C_ALPHA_FULL_TRANSPARENT As Byte = 0

Private Const C_ALPHA_FULL_OPAQUE As Byte = 255

Private Const WS_DLGFRAME = &H400000

Private Const WS_THICKFRAME = &H40000

Private Const WS_SIZEBOX = WS_THICKFRAME

Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_MINIMIZEBOX = &H20000

Public Enum FORM_PARENT_WINDOW_TYPE

FORM_PARENT_NONE = 0

FORM_PARENT_APPLICATION = 1

FORM_PARENT_WINDOW = 2

End Enum

Private Declare Function SetParent Lib "user32" ( _

ByVal hWndChild As Long, _

ByVal hWndNewParent 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _

ByVal hwnd As Long, _

ByVal nIndex 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 SetLayeredWindowAttributes Lib "user32" ( _

ByVal hwnd As Long, _

ByVal crey As Byte, _

ByVal bAlpha As Byte, _

ByVal dwFlags As Long) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _

ByVal hWnd1 As Long, _

ByVal hWnd2 As Long, _

ByVal lpsz1 As String, _

ByVal lpsz2 As String) As Long

Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Declare Function DrawMenuBar Lib "user32" ( _

ByVal hwnd As Long) As Long

Private Declare Function GetMenuItemCount Lib "user32" ( _

ByVal hMenu As Long) As Long

Private Declare Function GetSystemMenu Lib "user32" ( _

ByVal hwnd As Long, _

ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" ( _

ByVal hMenu As Long, _

ByVal nPosition As Long, _

ByVal wFlags As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _

ByVal hwnd As Long, _

ByVal lpString As String, _

ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _

ByVal hwnd As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _

ByVal hwnd As Long, _

ByVal lpClassName As String, _

ByVal nMaxCount As Long) As Long

Private Declare Function EnableMenuItem Lib "user32" ( _

ByVal hMenu As Long, _

ByVal wIDEnableItem As Long, _

ByVal wEnable As Long) As Long

Function ShowMaximizeButton(UF As MSForms.UserForm, _

HideButton As Boolean) As Boolean

Dim UFHWnd As Long

Dim WinInfo As Long

Dim R As Long

UFHWnd = HWndOfUserForm(UF)

If UFHWnd = 0 Then

ShowMaximizeButton = False

Exit Function

End If

WinInfo = GetWindowLong(UFHWnd, GWL_STYLE)

If HideButton = False Then

WinInfo = WinInfo Or WS_MAXIMIZEBOX

Else

WinInfo = WinInfo And (Not WS_MAXIMIZEBOX)

End If

R = SetWindowLong(UFHWnd, GWL_STYLE, WinInfo)

ShowMaximizeButton = (R <> 0)

End Function

Function ShowMinimizeButton(UF As MSForms.UserForm, _

HideButton As Boolean) As Boolean

Dim UFHWnd As Long

Dim WinInfo As Long

Dim R As Long

UFHWnd = HWndOfUserForm(UF)

If UFHWnd = 0 Then

ShowMinimizeButton = False

Exit Function

End If

WinInfo = GetWindowLong(UFHWnd, GWL_STYLE)

If HideButton = False Then

WinInfo = WinInfo Or WS_MINIMIZEBOX

Else

WinInfo = WinInfo And (Not WS_MINIMIZEBOX)

End If

R = SetWindowLong(UFHWnd, GWL_STYLE, WinInfo)

ShowMinimizeButton = (R <> 0)

End Function

Function SetFormParent(UF As MSForms.UserForm, _

Parent As FORM_PARENT_WINDOW_TYPE) As Boolean

Dim UFHWnd As Long

Dim WindHWnd As Long

Dim R As Long

UFHWnd = HWndOfUserForm(UF)

If UFHWnd = 0 Then

SetFormParent = False

Exit Function

End If

Select Case Parent

Case FORM_PARENT_APPLICATION

R = SetParent(UFHWnd, Application.hwnd)

Case FORM_PARENT_NONE

R = SetParent(UFHWnd, 0&)

Case FORM_PARENT_WINDOW

If Application.ActiveWindow Is Nothing Then

SetFormParent = False

Exit Function

End If

WindHWnd = WindowHWnd(Application.ActiveWindow)

If WindHWnd = 0 Then

SetFormParent = False

Exit Function

End If

R = SetParent(UFHWnd, WindHWnd)

Case Else

SetFormParent = False

Exit Function

End Select

SetFormParent = (R <> 0)

End Function

Function MakeFormResizable(UF As MSForms.UserForm, Sizable As Boolean) As Boolean

Dim UFHWnd As Long

Dim WinInfo As Long

Dim R As Long

UFHWnd = HWndOfUserForm(UF)

If UFHWnd = 0 Then

MakeFormResizable = False

Exit Function

End If

WinInfo = GetWindowLong(UFHWnd, GWL_STYLE)

If Sizable = True Then

WinInfo = WinInfo Or WS_SIZEBOX

Else

WinInfo = WinInfo And (Not WS_SIZEBOX)

End If

R = SetWindowLong(UFHWnd, GWL_STYLE, WinInfo)

MakeFormResizable = (R <> 0)

End Function

Function HWndOfUserForm(UF As MSForms.UserForm) As Long

Dim AppHWnd As Long

Dim DeskHWnd As Long

Dim WinHWnd As Long

Dim UFHWnd As Long

Dim Cap As String

Dim WindowCap As String

Cap = UF.Caption

UFHWnd = FindWindow(C_USERFORM_CLASSNAME, Cap)

If UFHWnd <> 0 Then

HWndOfUserForm = UFHWnd

Exit Function

End If

AppHWnd = Application.hwnd

UFHWnd = FindWindowEx(AppHWnd, 0&, C_USERFORM_CLASSNAME, Cap)

If UFHWnd <> 0 Then

HWndOfUserForm = UFHWnd

Exit Function

End If

If Application.ActiveWindow Is Nothing Then

HWndOfUserForm = 0

Exit Function

End If

WinHWnd = WindowHWnd(Application.ActiveWindow)

UFHWnd = FindWindowEx(WinHWnd, 0&, C_USERFORM_CLASSNAME, Cap)

HWndOfUserForm = UFHWnd

End Function

Secondo codice inserito in un altro modulo standard nominato WindowsFunctions:

Private Sub UserForm_Initialize()

AllowResize = True

OldWidth = Width

OldHeight = Height

If Val(Application.Version) < 9 Then

hwnd = FindWindow("ThunderXFrame", Caption) 'XL97

Else

hwnd = FindWindow("ThunderDFrame", Caption) 'XL2000

End If

PrevStyle = GetWindowLong(hwnd, GWL_STYLE)

SetWindowLong hwnd, GWL_STYLE, PrevStyle _

Or WS_SIZEBOX _

Or WS_MINIMIZEBOX _

Or WS_MAXIMIZEBOX

'<--- dichiarazioni variabili e impostazioni array intestazioni ListBox --->

Dim sLB_Header_Crew As Variant

Dim sLB_Header_CertificateOnBoard As Variant

Dim sLB_Header_CertificateExpired As Variant

sLB_Header_Crew = Array("Rank", "Surname & Name", "Nationality")

sLB_Header_CertificateOnBoard = Array("Certificate Type", "M/R", "Expiring Date") '<--- 22/07/2016 modifica per inserire la colonna M/R nella ListBox CertificateOnBoard

sLB_Header_CertificateExpired = Array("Certificate Type", "Expiring Date", "Day Left")

'<--- memorizzo la data odierna --->

Today = Date

'<--- impostazioni iniziali ListBox --->

With Me

.TabStrip1.Value = 0

'<--- Call Set Workbook, Worksheets e Range --->

Call SetWorksheets

With .LB_Crew

.List() = CR1.Offset(1, 0).Resize(NumRowCR1 - 1, NumColPersonalData).Value

End With

End Sub

Option Explicit

Option Compare Text

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _

ByVal hWnd1 As Long, _

ByVal hWnd2 As Long, _

ByVal lpsz1 As String, _

ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _

ByVal hwnd As Long, _

ByVal lpString As String, _

ByVal cch As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _

ByVal HKey As Long, _

ByVal lpSubKey As String, _

ByVal ulOptions As Long, _

ByVal samDesired As Long, _

phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _

ByVal HKey As Long, _

ByVal lpValueName As String, _

ByVal lpReserved As Long, _

LPType As Long, _

LPData As Any, _

lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" ( _

ByVal HKey As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _

ByVal hwnd As Long, _

ByVal lpClassName As String, _

ByVal nMaxCount As Long) As Long

Private Const HKEY_CURRENT_USER As Long = &H80000001

Private Const HKEY_LOCAL_MACHINE As Long = &H80000002

Private Const HKEY_CLASSES_ROOT As Long = &H80000000

Private Const HKEY_CURRENT_CONFIG As Long = &H80000005

Private Const HKEY_DYN_DATA As Long = &H80000006

Private Const HKEY_PERFORMANCE_DATA As Long = &H80000004

Private Const HKEY_USERS As Long = &H80000003

Private Const KEY_ALL_ACCESS As Long = &H3F

Private Const ERROR_SUCCESS As Long = 0&

Private Const HKCU As Long = HKEY_CURRENT_USER

Private Const HKLM As Long = HKEY_LOCAL_MACHINE

Private Enum REG_DATA_TYPE

REG_DATA_TYPE_DEFAULT = 0

REG_INVALID = -1

REG_SZ = 1

REG_DWORD = 4

End Enum

Private Const C_EXCEL_APP_CLASSNAME = "XLMain"

Private Const C_EXCEL_DESK_CLASSNAME = "XLDesk"

Private Const C_EXCEL_WINDOW_CLASSNAME = "EXCEL7"

Function DoesWindowsHideFileExtensions() As Boolean

Dim Res As Long

Dim RegKey As Long

Dim v As Long

Const KEY_NAME = "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"

Const VALUE_NAME = "HideFileExt"

Res = RegOpenKeyEx(HKey:=HKCU, _

lpSubKey:=KEY_NAME, _

ulOptions:=0&, _

samDesired:=KEY_ALL_ACCESS, _

phkResult:=RegKey)

If Res <> ERROR_SUCCESS Then

Exit Function

End If

Res = RegQueryValueEx(HKey:=RegKey, _

lpValueName:=VALUE_NAME, _

lpReserved:=0&, _

LPType:=REG_DWORD, _

LPData:=v, _

lpcbData:=Len(v))

If Res <> ERROR_SUCCESS Then

RegCloseKey RegKey

Exit Function

End If

RegCloseKey RegKey

DoesWindowsHideFileExtensions = (v <> 0)

End Function

Function WindowCaption(W As Excel.Window) As String

Dim HideExt As Boolean

Dim Cap As String

Dim Pos As Long

HideExt = DoesWindowsHideFileExtensions()

Cap = W.Caption

If HideExt = True Then

Pos = InStrRev(Cap, ".")

If Pos > 0 Then

Cap = Left(Cap, Pos - 1)

End If

WindowCaption = Cap

End Function

Function WindowHWnd(W As Excel.Window) As Long

Dim AppHWnd As Long

Dim DeskHWnd As Long

Dim WHWnd As Long

Dim Cap As String

AppHWnd = Application.hwnd

DeskHWnd = FindWindowEx(AppHWnd, 0&, C_EXCEL_DESK_CLASSNAME, vbNullString)

If DeskHWnd > 0 Then

Cap = WindowCaption(W)

WHWnd = FindWindowEx(DeskHWnd, 0&, C_EXCEL_WINDOW_CLASSNAME, Cap)

End If

WindowHWnd = WHWnd

End Function

Function WindowText(hwnd As Long) As String

Dim S As String

Dim n As Long

n = 255

S = String$(n, vbNullChar)

n = GetWindowText(hwnd, S, n)

If n > 0 Then

WindowText = Left(S, n)

Else

WindowText = vbNullString

End If

End Function

Function WindowClassName(hwnd As Long) As String

Dim S As String

Dim n As Long

n = 255

S = String$(n, vbNullChar)

n = GetClassName(hwnd, S, n)

If n > 0 Then

WindowClassName = Left(S, n)

Else

WindowClassName = vbNullString

End If

End Function

Codice insertito nella Userform1:

Option Explicit

Option Compare Text

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _

(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 Const GWL_STYLE = (-16)

Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_MINIMIZEBOX = &H20000

Private Const WS_THICKFRAME = &H40000

Private Const WS_SIZEBOX = WS_THICKFRAME

Private Const WS_MAXIMIZE = &H1000000

Private Const WS_MINIMIZE = &H20000000

Private Const SW_ERASE = &H4

Private Const SW_HIDE = 0

Private Const SW_INVALIDATE = &H2

Private Const SW_MAX = 10

Private Const SW_MAXIMIZE = 3

Private Const SW_MINIMIZE = 6

Private Const SW_NORMAL = 1

Private Const SW_OTHERUNZOOM = 4

Private Const SW_OTHERZOOM = 2

Private Const SW_PARENTCLOSING = 1

Private Const SW_PARENTOPENING = 3

Private Const SW_RESTORE = 9

Private Const SW_SCROLLCHILDREN = &H1

Private Const SW_SHOW = 5

Private Const SW_SHOWDEFAULT = 10

Private Const SW_SHOWMAXIMIZED = 3

Private Const SW_SHOWMINIMIZED = 2

Private Const SW_SHOWMINNOACTIVE = 7

Private Const SW_SHOWNA = 8

Private Const SW_SHOWNOACTIVATE = 4

Private Const SW_SHOWNORMAL = 1

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Const ZoomMin = 10 'VBA cho phep thap nhat la 10

Private Const ZoomMax = 400 'VBA cho phep muc cao nhat la 400. Ban co the tu thay doi ZoomMin va ZoomMax trong pham vi 10-400

Dim hwnd&, PrevStyle&

Dim OldWidth As Double, OldHeight As Double

Dim AllowResize As Boolean

Private Sub UserForm_Initialize()

AllowResize = True

OldWidth = Width

OldHeight = Height

If Val(Application.Version) < 9 Then

hwnd = FindWindow("ThunderXFrame", Caption) 'XL97

Else

hwnd = FindWindow("ThunderDFrame", Caption) 'XL2000

End If

PrevStyle = GetWindowLong(hwnd, GWL_STYLE)

SetWindowLong hwnd, GWL_STYLE, PrevStyle _

Or WS_SIZEBOX _

Or WS_MINIMIZEBOX _

Or WS_MAXIMIZEBOX

End Sub

Private Sub UserForm_Resize()

Dim tmpZoom&, CurStyle&

Dim tmpWidth As Double

If Not AllowResize Then Exit Sub

CurStyle = GetWindowLong(hwnd, GWL_STYLE)

tmpZoom = Round(Width / OldWidth * 100, 0)

If tmpZoom < ZoomMin Then tmpZoom = ZoomMin

If tmpZoom > ZoomMax Then tmpZoom = ZoomMax

AllowResize = False 'Ngan khong chay UserForm_Resize khi dang thay doi size

If tmpZoom = ZoomMin Or tmpZoom = ZoomMax Then

'Neu khong phai la phong to man hinh thi co lai kich co

If Not (CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Then

Width = tmpZoom * OldWidth / 100

Height = Width * OldHeight / OldWidth

End If

If (CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Then

tmpWidth = OldWidth * Height / OldHeight

tmpZoom = Round(tmpWidth / OldWidth * 100, 0) 'limitZoom

End If

'Change height by width

'If Not ((CurStyle And WS_MAXIMIZE) = WS_MAXIMIZE Or _

' (CurStyle And WS_MINIMIZE) = WS_MINIMIZE) Then

' Height = Width * OldHeight / OldWidth

'End If

AllowResize = True 'Cho phep resize

Zoom = tmpZoom

End Sub

Private Sub UserForm_Terminate()

With Application

.DisplayAlerts = False

.Visible = True

.DisplayAlerts = True

End With

SetWindowLong hwnd, GWL_STYLE, PrevStyle

End Sub

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Oltre a ridimensionare la UserForm, ci sono anche i controlli, immagino.... ;-)

Vedi ad esempio:

http://thetruster.altervista.org/index.php/programmazione/articoli/29-adattare-un-form-alla-risoluzione-dello-schermo

Cercando in rete trovi anche altro.

0 commenti

6 risposte aggiuntive

Answer 1

Non credo che Norman intendessi diversi file ma, all'interno del medesimo file, diverse UserForm, identiche nei contenuti e programmazione, ma di differenti dimensioni.

Ma se, sempre con l'approccio di Norman, si provasse a "giocare" con lo Zoom della UserForm?

Tipo assegnare un valore ad una variabile e poi assegnare questa variabile all'initialize della user?

Tipo qualcosa del genere (valori messi a caso ovviamente):

Public UfZoom as Long

Poi il codice Select Case di Norman

Select Case vidWidth

Case 1152, 1280

UfZoom = 105

Case 1440

UfZoom =110

Case 1600

UfZoom =95

Case Else

UfZoom = 100

End Select

Answer 2

Grazie Mauro e grazie Norman,

purtroppo non posso salvare varie versioni del file in quanto e' in rete sulla nave e quindi vari utenti aggiornano lo stesso file.

In effetti negli uffici abbiamo tutti lo stesso monitor quindi il problema non sussiste. Mi sono accorto di questo problemino solo quando ho trasferito il file sul computer della mia cabina che ha un monitor diverso.

Pero' in definitiva la schermata della userform la vedo tutta, e' solo che sul lato destro resta la userform vuota ed i controlli non si dimensionano del tutto.

So bene che ho chiesto una cosa quasi impossibile per VBA, ma io ci provo sempre magari nelle prossime versioni di excel inseriranno anche il pulsante ad icona e l'ingrandimento.

Grazie come al solito dei vostri preziosi aiuti.

Oggi sono riuscito a completare tutto il programma e spero che lavorandoci sopra non escano troppi errori cosi' non vi daro' fastidio.

Saluti

Giuseppe

Answer 3

Ciao Giuseppe,

Vorrei suggerire un diverso approccio al problema, vale a dire leggere la risoluzione dello schermo dell'utente e quindi visualizzare una Userform adeguata in risposta alla risoluzione. Potresti cambiare la risoluzione del proprio schermo, adattare la Userform e salvare ogni versione con un nuovo nome.

'=========>>

Option Explicit

'--------->>

Declare Function GetSystemMetrics32 Lib "user32" _

Alias "GetSystemMetrics" _

(ByVal nIndex As Long) As Long

Public Const SM_CXSCREEN = 0

Public Const SM_CYSCREEN = 1

'--------->>

Public Sub Tester()

Dim vidWidth As Long

Dim vidHeight As Long

Dim sMsg As String

vidWidth = GetSystemMetrics32(SM_CXSCREEN)

vidHeight = GetSystemMetrics32(SM_CYSCREEN)

sMsg = "The current video mode is: "

sMsg = sMsg & vidWidth & " X " & vidHeight

Call MsgBox( _

Prompt:=sMsg, _

Buttons:=vbInformation, _

Title:="DEMO")

Select Case vidWidth

Case 1152, 1280

UserForm1280x960.Show

Case 1440

UserForm1440x900.Show

Case 1600

UserForm1600x1200.Show

Case Else

UserFormX.Show

End Select

End Sub

'<<=========

===

Regards,

Norman

Answer 4

Anonimo

VB/VBA non hanno nulla di nativo per fare ciò che chiedi.

Devi tu ridimensionare in base alla dimensione dello schermo.

0 commenti