Code:
[Cc][+][-]
Option Explicit
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Dim hTimer As LongPtr
Dim sInputBoxCaption As String
Sub ClickOk()
Dim sText As String
On Error GoTo Fehler
sInputBoxCaption = "Meine Inputbox"
hTimer = SetTimer(0&, 0&, 50, AddressOf DlgInputBox)
sText = InputBox("Mein Default", sInputBoxCaption)
Fehler:
KillTimer 0&, hTimer
End Sub
Private Sub DlgInputBox()
' Setzt die Dg dauerhaft in den Vordergrund
Dim hDlg As LongPtr
hDlg = FindWindowA("#32770", sInputBoxCaption)
If hDlg > 0 Then
KillTimer 0&, hTimer
SetWindowPos hDlg, HWND_TOPMOST, 0, 0, 0, 0, &H3
End If
End Sub
Code:
[Cc][+][-]
Option Explicit
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Dim hTimer As LongPtr
Dim sInputBoxCaption As String
Sub Inpuboxtest()
Dim sText As String
On Error GoTo Fehler
sInputBoxCaption = "Meine Inputbox"
hTimer = SetTimer(0&, 0&, 50, AddressOf DlgInputBoxProc)
sText = InputBox("Mein Default", sInputBoxCaption)
Fehler:
KillTimer 0&, hTimer
End Sub
Private Sub DlgInputBoxProc()
' Setzt die Dlg dauerhaft in den Vordergrund
Dim hDlg As LongPtr
hDlg = FindWindowA("#32770", sInputBoxCaption)
If hDlg > 0 Then
KillTimer 0&, hTimer
SetWindowPos hDlg, HWND_TOPMOST, 0, 0, 0, 0, &H3
End If
End Sub
Sub ClickOk()
Dim sText As String
On Error Resume next
sInputBoxCaption = "Meine Inputbox"
hTimer = SetTimer(0&, 0&, 50, AddressOf DlgInputBox)
sText = InputBox("Mein Default", sInputBoxCaption)
On Error Goto 0