AW: Userform Zoom
14.03.2018 16:56:57
Peter(silie)
Hallo,
unten Code und eine Beispiele Mappe die dir Vielleicht helfen könnten.
Verwendet Windows API Funktionen um die Userform und die Control größen zu ändern.
Hier Mappe: https://www.herber.de/bbs/user/120419.xlsm
Hier Code der UserForm:
Private Sub UserForm_Activate()
ScaleControls
End Sub
Private Sub ScaleControls()
Dim w As Long
Dim h As Long
Dim ppi As Double
Dim ct As Control
w = ZoomHandler.GetSystemWidth
'Falls die Breite kleiner 1920 ist
'Ich gehe mal davon aus dass der Hauptbildschirm 1920x1080 hat
'Die anderen somit kleiner sind und die UF kleiner dargestellt werden sollte
If w "CommandButton" Then
'füge am Ende * 0.9 hinzu, wenns sie noch kleiner seien sollen
'Breite
ct.Width = ct.Width * ppi
'Höhe
ct.Height = ct.Height * ppi
'Position Links
ct.Left = ct.Left * ppi
'Position Oben
ct.Top = ct.Top * ppi
'Schriftgröße
ct.Font.Size = CLng(ct.Font.Size * ppi)
End If
Next ct
End If
End Sub
Hier Code des Moduls "ZoomHandler":
Option Explicit
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetSystemMetrics32 _
Lib "user32.dll" Alias "GetSystemMetrics" _
(ByVal nIndex As Long) _
As Long
Private Declare PtrSafe Function GetDeviceCaps _
Lib "gdi32.dll" _
(ByVal hDC As LongPtr, _
ByVal nIndex As Long) _
As Long
Private Declare PtrSafe Function GetDC _
Lib "user32.dll" _
(ByVal hWnd As LongPtr) _
As LongPtr
Private Declare PtrSafe Function ReleaseDC _
Lib "user32.dll" _
(ByVal hWnd As LongPtr, _
ByVal hDC As LongPtr) _
As Long
#Else
Private Declare Function GetSystemMetrics32 _
Lib "user32.dll" Alias "GetSystemMetrics" _
(ByVal nIndex As Long) _
As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal nIndex As Long) _
As Long
Private Declare Function GetDC _
Lib "user32.dll" _
(ByVal hWnd As Long) _
As Long
Private Declare Function ReleaseDC _
Lib "user32.dll" _
(ByVal hWnd As Long, _
ByVal hDC As Long) _
As Long
#End If
#Else
Private Declare Function GetSystemMetrics32 _
Lib "user32.dll" Alias "GetSystemMetrics" _
(ByVal nIndex As Long) _
As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32.dll" _
(ByVal hDC As Long, _
ByVal nIndex As Long) _
As Long
Private Declare Function GetDC _
Lib "user32.dll" _
(ByVal hWnd As Long) _
As Long
Private Declare Function ReleaseDC _
Lib "user32.dll" _
(ByVal hWnd As Long, _
ByVal hDC As Long) _
As Long
#End If
'returns the value of the Points per pixel of the current screen
Public Function PointsPerPixel() As Double
Dim hDC As Long
Dim lDotsPerInch As Long
Const LOGPIXELSX As Long = 88
Const POINTS_PER_INCH As Long = 72
hDC = GetDC(0)
lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
ReleaseDC 0, hDC
End Function
'returns the width of the current screen
Public Function GetSystemWidth() As Long
GetSystemWidth = GetSystemMetrics32(0)
End Function
'returns the height of the current screen
Public Function GetSystemHeight() As Long
GetSystemHeight = GetSystemMetrics32(1)
End Function