Option Explicit
Public Type FORMAT_ATTRIBUTES
TITLE_FONT_COLOR As Long
INPUT_FONT_COLOR As Long
INPUT_BCKG_COLOR As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Type PAINTSTRUCT
#If VBA7 Then
hdc As LongPtr
#Else
hdc As Long
#End If
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0 To 31) As Byte
End Type
Type Msg
#If VBA7 Then
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
#Else
hwnd As Long
message As Long
wParam As Long
lParam As Long
#End If
time As Long
pt As POINTAPI
End Type
#If VBA7 Then
#If Win64 Then
Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
#End If
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As LongPtr
Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hdc As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
#Else
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
#End If
Private bXitLoop As Boolean
Private sInputMessage As String
Private sInputTitle As String
Private tAttributes As FORMAT_ATTRIBUTES
Public Property Let FormatDVInputMessage(ByVal Cell As Range, FormatAttributes As FORMAT_ATTRIBUTES, ByVal Format As Boolean)
If Format Then
tAttributes = FormatAttributes
sInputMessage = Cell.Validation.InputMessage
sInputTitle = Cell.Validation.InputTitle
Call SetTimer(Application.hwnd, 0, 0, AddressOf FindInputMessageHwnd)
Else
Call ClearHook
End If
End Property
Private Sub FindInputMessageHwnd()
#If VBA7 Then
Dim lDVhwnd As LongPtr
#Else
Dim lDVhwnd As Long
#End If
lDVhwnd = FindWindowEx(FindWindow("XLMAIN", Application.Caption), 0, "EXCELA", vbNullString)
Call SetProp(Application.hwnd, "lDVhwnd", lDVhwnd)
Call ShowWindow(lDVhwnd, 0)
Call ShowWindow(lDVhwnd, 1)
If lDVhwnd <> 0 Then
Call KillTimer(Application.hwnd, 0)
Call FormatDVMsg(ByVal sInputTitle, ByVal sInputMessage)
End If
End Sub
Private Sub FormatDVMsg(ByVal MsgTitle As String, ByVal MsgInput As String)
#If VBA7 Then
Dim lPrevWnd As LongPtr
#Else
Dim lPrevWnd As Long
#End If
Const GWL_WNDPROC As Long = -4
If GetProp(Application.hwnd, "lPrev") = 0 Then
lPrevWnd = SetWindowLong(GetProp(Application.hwnd, "lDVhwnd"), GWL_WNDPROC, AddressOf CallBackProc)
Call SetProp(Application.hwnd, "lPrev", lPrevWnd)
Call InvalidateRect(GetProp(Application.hwnd, "lDVhwnd"), 0, 0)
Call MessageLoop
End If
End Sub
#If VBA7 Then
Private Function CallBackProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim hBrush As LongPtr, hdc As LongPtr
#Else
Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hBrush As Long, hdc As Long
#End If
Const WM_PAINT As Long = &HF&
Const DT_WORDBREAK = &H10
Const DT_INTERNAL = &H1000
Const BDR_SUNKENOUTER = &H2
Const BDR_RAISEDINNER = &H4
Const BF_LEFT = &H1
Const BF_TOP = &H2
Const BF_RIGHT = &H4
Const BF_BOTTOM = &H8
Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Dim tClientRect As RECT, tPS As PAINTSTRUCT
If IsVBEActive Then
Call ClearHook
Exit Function
End If
With tAttributes
Select Case Msg
Case WM_PAINT
Call GetClientRect(hwnd, tClientRect)
hdc = BeginPaint(hwnd, tPS)
hBrush = CreateSolidBrush(.INPUT_BCKG_COLOR)
Call FillRect(hdc, tClientRect, hBrush)
Call DeleteObject(hBrush)
Call DrawEdge(hdc, tClientRect, EDGE_ETCHED, BF_RECT)
Call SetTextColor(hdc, .TITLE_FONT_COLOR)
tClientRect.Left = tClientRect.Left + 6
Call CreateFont(hdc, True)
Call DrawText(hdc, sInputTitle, -1, tClientRect, DT_INTERNAL)
Call SetTextColor(hdc, .INPUT_FONT_COLOR)
tClientRect.Top = tClientRect.Top + 20
Call CreateFont(hdc, False)
Call DrawText(hdc, sInputMessage, -1, tClientRect, DT_WORDBREAK + DT_INTERNAL)
Call EndPaint(hwnd, tPS)
End Select
End With
CallBackProc = CallWindowProc(GetProp(Application.hwnd, "lPrev"), hwnd, Msg, wParam, ByVal lParam)
End Function
Private Sub MessageLoop()
Dim tMsg As Msg
On Error Resume Next
bXitLoop = False
Do While GetMessage(tMsg, 0, 0, 0) And bXitLoop = False
DoEvents
Call TranslateMessage(tMsg)
Call DispatchMessage(tMsg)
Call PostMessage(tMsg.hwnd, tMsg.message, tMsg.wParam, tMsg.lParam)
Loop
End Sub
#If VBA7 Then
Private Sub CreateFont(ByVal DC As LongPtr, ByVal Title As Boolean)
Dim lNewFont As LongPtr
#Else
Private Sub CreateFont(ByVal DC As Long, ByVal Title As Boolean)
Dim lNewFont As Long
#End If
Dim uFont As LOGFONT
With uFont
.lfFaceName = "Calibri" & Chr$(0)
.lfHeight = IIf(Title, 20, 15)
.lfWeight = IIf(Title, 900, 100)
End With
lNewFont = CreateFontIndirect(uFont)
DeleteObject (SelectObject(DC, lNewFont))
End Sub
Private Sub ClearHook()
Const GWL_WNDPROC As Long = -4
bXitLoop = True
If GetProp(Application.hwnd, "lPrev") Then
Call SetWindowLong(GetProp(Application.hwnd, "lDVhwnd"), GWL_WNDPROC, GetProp(Application.hwnd, "lPrev"))
Call ShowWindow(GetProp(Application.hwnd, "lDVhwnd"), 0)
Call RemoveProp(Application.hwnd, "lDVhwnd")
Call RemoveProp(Application.hwnd, "lPrev")
End If
End Sub
Private Function IsVBEActive() As Boolean
IsVBEActive = CBool(GetActiveWindow = FindWindow("wndclass_desked_gsk", vbNullString))
End Function
Private Sub Auto_Close()
Call ClearHook
End Sub