AW: VBA Userform Maximieren &Tastatur öffnen
12.11.2020 08:20:40
Nepumuk
Hallo Excelaner,
Userform in Bildschirmgröße mit anpassen der Controls:
Option Explicit
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As LongPtr
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
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0&
Private Const SM_CYSCREEN As Long = 1&
Private Const LOGPIXELS_X As Long = 88&
Private Const LOGPIXELS_Y As Long = 90&
Private Sub CommandButton1_Click()
Call Unload(Object:=Me)
End Sub
Private Sub UserForm_Activate()
Dim sngWidth As Single, sngHeight As Single
sngWidth = Width
sngHeight = Height
Left = 0
Top = 0
Width = GetSystemMetrics(SM_CXSCREEN) * GetResolution(LOGPIXELS_X)
Height = GetSystemMetrics(SM_CYSCREEN) * GetResolution(LOGPIXELS_Y)
Zoom = Fix(Application.Min(Width / sngWidth, Height / sngHeight) * 100)
End Sub
Private Function GetResolution(ByVal pvlngLogPixel As Long) As Single
Dim lngptrhWndDesk As LongPtr, lngptrhDCDesk As LongPtr
Dim lnglogPixel As Long
lngptrhWndDesk = GetDesktopWindow()
lngptrhDCDesk = GetDC(lngptrhWndDesk)
lnglogPixel = GetDeviceCaps(lngptrhDCDesk, pvlngLogPixel)
Call ReleaseDC(lngptrhWndDesk, lngptrhDCDesk)
GetResolution = 72 / lnglogPixel
End Function
Bildschirmtastatur öffnen / schließen:
Option Explicit
Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
Private Declare PtrSafe Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" ( _
ByVal Enable As Boolean) As Boolean
Private Declare PtrSafe Function IsWow64Process Lib "kernel32.dll" ( _
ByVal hProcess As LongPtr, _
ByRef Wow64Process As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32.dll" () As LongPtr
Private Const SW_SHOWNORMAL As Long = 1
Public Sub LoadScreenKeyboard()
Dim lngptrIsWow64 As LongPtr, lngptrProcess As LongPtr
lngptrProcess = GetCurrentProcess
Call IsWow64Process(lngptrProcess, lngptrIsWow64)
If lngptrIsWow64 = 0 Then
Call ShellExecuteA(Application.hwnd, "open", "osk.exe", vbNullString, "C:\Windows\System32\", SW_SHOWNORMAL)
Else
Call Wow64EnableWow64FsRedirection(False)
Call ShellExecuteA(Application.hwnd, "open", "osk.exe", vbNullString, "C:\Windows\System32\", SW_SHOWNORMAL)
Call Wow64EnableWow64FsRedirection(True)
End If
End Sub
Public Sub UnloadScreenKeyboard()
Dim objWMIService As Object, objProcessList As Object, objProcess As Object
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objProcessList = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'osk.exe'")
For Each objProcess In objProcessList
Call objProcess.Terminate
Next
Set objProcessList = Nothing
Set objWMIService = Nothing
End Sub
Gruß
Nepumuk