Option Explicit
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
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function GetWindowDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject 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 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
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare Function GetMessage Lib "user32.dll" _
Alias "GetMessageA" _
(ByRef lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" _
(ByRef lpMsg As MSG) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private 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
Private Declare Function DrawEdge Lib "user32" _
(ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
[COLOR=seagreen][B]'========================================[/B][/COLOR]
'System Constantes.
Private Const GWL_WNDPROC As Long = -4
Private Const WM_PAINT As Long = &HF&
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const DT_WORDBREAK As Long = &H10
Private Const BDR_RAISEDOUTER As Long = &H1
Private Const BDR_SUNKENINNER As Long = &H8
Private Const EDGE_BUMP As Long = _
(BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const BF_LEFT As Long = &H1
Private Const BF_RIGHT As Long = &H4
Private Const BF_TOP As Long = &H2
Private Const BF_BOTTOM As Long = &H8
Private Const BF_RECT As Long = _
(BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
[COLOR=seagreen][B]'=====================================[/B][/COLOR]
[B][COLOR=seagreen]'User global Constantes.[/COLOR][/B]
[B][COLOR=seagreen]'Change their values as required.[/COLOR][/B]
Private Const TITLE_FONT_HEIGHT = 16
Private Const TITLE_FONT_WIDTH = 6
Private Const TITLE_FONT_BOLD = True
Private Const TITLE_FONT_COLOR = vbRed
Private Const INPUT_FONT_HEIGHT = 14
Private Const INPUT_FONT_WIDTH = 5
Private Const INPUT_FONT_BOLD = False
Private Const INPUT_FONT_COLOR = vbBlue
Private Const INPUT_BCKG_COLOR = vbCyan
[COLOR=seagreen][B]'this is the DV input msg box[/B][/COLOR]
[COLOR=seagreen][B]'class name in XL 2003.[/B][/COLOR]
[COLOR=seagreen][B]'not sure about other XL versions.[/B][/COLOR]
Private Const DV_INPUT_MSG_CLASS As String = "EXCELA"
[COLOR=seagreen][B]'====================================[/B][/COLOR]
[COLOR=seagreen][B]'Module variables.[/B][/COLOR]
Private tWnRect As RECT
Private tClientRect As RECT
Private bXitLoop As Boolean
Private bFirstCall As Boolean
Private sInputMessage As String
Private sInputTitle As String
Private lDVhwnd As Long
Private lTimerID As Long
Private ldc As Long
[COLOR=seagreen][B]'==============================[/B][/COLOR]
[COLOR=seagreen][B]'Global Vars.[/B][/COLOR]
Public lPrevWnd As Long
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal MSG As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tPS As PAINTSTRUCT
Dim tLB As LOGBRUSH
Dim hBrush As Long
On Error Resume Next
[COLOR=seagreen][B]'build the default brush.[/B][/COLOR]
tLB.lbColor = INPUT_BCKG_COLOR
hBrush = CreateBrushIndirect(tLB)
[COLOR=seagreen][B]'store the DV dimensions.[/B][/COLOR]
GetClientRect hwnd, tClientRect
GetWindowRect hwnd, tWnRect
[COLOR=seagreen][B]'intercept the WM_PAINT Msg.[/B][/COLOR]
Select Case MSG
Case WM_PAINT
If bFirstCall Then
SetWindowPos hwnd, 0, 0, 0, _
tWnRect.Right - tWnRect.Left, _
(tWnRect.Bottom - tWnRect.Top) + 10, _
SWP_NOACTIVATE + SWP_NOMOVE
bFirstCall = False
End If
[COLOR=seagreen][B]'start the text & bckgrnd formatting.[/B][/COLOR]
ldc = BeginPaint(hwnd, tPS)
SetBkMode ldc, 1
FillRect ldc, tClientRect, hBrush
DrawEdge ldc, tClientRect, EDGE_BUMP, BF_RECT
tClientRect.Left = tClientRect.Left + 5
tClientRect.Top = tClientRect.Top + 5
SetTextColor ldc, TITLE_FONT_COLOR
sInputTitle = sInputTitle & vbNewLine & vbNewLine
CreateTitleFont ldc, sInputTitle
DrawText ldc, sInputTitle, Len(sInputTitle), _
tClientRect, DT_WORDBREAK
SetTextColor ldc, INPUT_FONT_COLOR
CreateInputFont ldc, sInputTitle
tClientRect.Top = tClientRect.Top + 20
DrawText ldc, sInputMessage, Len(sInputMessage), _
tClientRect, DT_WORDBREAK
Call DeleteObject(hBrush)
ReleaseDC hwnd, ldc
EndPaint hwnd, tPS
End Select
[COLOR=seagreen][B]'process other msgs.[/B][/COLOR]
CallBackProc = CallWindowProc _
(lPrevWnd, hwnd, MSG, wParam, ByVal lParam)
End Function
Private Sub CreateTitleFont(DC As Long, text As String)
Dim uFont As LOGFONT
Dim lNewFont As Long
With uFont
.lfFaceName = "Arial" & Chr$(0)
.lfUnderline = True
.lfHeight = TITLE_FONT_HEIGHT
.lfWidth = TITLE_FONT_WIDTH
.lfWeight = IIf(TITLE_FONT_BOLD, 900, 100)
End With
lNewFont = CreateFontIndirect(uFont)
DeleteObject (SelectObject(DC, lNewFont))
End Sub
Private Sub CreateInputFont(DC As Long, text As String)
Dim uFont As LOGFONT
Dim lNewFont As Long
With uFont
.lfFaceName = "Arial" & Chr$(0)
.lfHeight = INPUT_FONT_HEIGHT
.lfWidth = INPUT_FONT_WIDTH
.lfWeight = IIf(INPUT_FONT_BOLD, 900, 100)
End With
lNewFont = CreateFontIndirect(uFont)
DeleteObject (SelectObject(DC, lNewFont))
End Sub
Private Sub FormatDVMsg _
(ByVal MsgTitle As String, ByVal MsgInput As String)
If lPrevWnd = 0 Then
lPrevWnd = SetWindowLong _
(lDVhwnd, GWL_WNDPROC, AddressOf CallBackProc)
[COLOR=seagreen][B]'send a Paint Msg to the DV box upon showing up.[/B][/COLOR]
InvalidateRect lDVhwnd, 0, 0
[COLOR=seagreen][B]'important!!![/B][/COLOR]
[COLOR=seagreen][B]' Msg pump for safe subclassing !!!![/B][/COLOR]
Call MessageLoop
End If
End Sub
Private Sub MessageLoop()
Dim aMsg As MSG
bXitLoop = False
On Error Resume Next
[COLOR=seagreen][B]'ensure all Msgs are posted during the subclassing.[/B][/COLOR]
Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
DoEvents
PostMessage 0, aMsg.message, aMsg.wParam, aMsg.lParam
Loop
End Sub
Public Sub StartTimer _
(ByVal MsgTitle As String, ByVal MsgInput As String)
[COLOR=seagreen][B] 'store the DV imput & title[/B][/COLOR]
[COLOR=seagreen][B]'messages in global vars.[/B][/COLOR]
sInputTitle = MsgTitle
sInputMessage = MsgInput
[COLOR=seagreen][B]'initiate SetWindowPos flag.[/B][/COLOR]
bFirstCall = True
[COLOR=seagreen][B]'timer to run the 'FormatDVMsg' routine.[/B][/COLOR]
[COLOR=seagreen][B]'required to work async with the Selection_Change[/B][/COLOR]
[COLOR=seagreen][B]'event.Doesn't put a strain on the system[/B][/COLOR]
[COLOR=seagreen][B]'as it only runs once upon a cell selection.[/B][/COLOR]
lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
End Sub
Public Sub ClearHook()
[COLOR=seagreen][B]'cleanUp.[/B][/COLOR]
bXitLoop = True
SetWindowLong lDVhwnd, GWL_WNDPROC, lPrevWnd
lPrevWnd = 0
lDVhwnd = 0
bFirstCall = True
End Sub
Private Sub TimerProc()
lDVhwnd = FindWindowEx _
(FindWindow("XLMAIN", Application.Caption), _
0, DV_INPUT_MSG_CLASS, vbNullString)
If lDVhwnd <> 0 Then
KillTimer 0, lTimerID
Call FormatDVMsg(ByVal sInputTitle, ByVal sInputMessage)
End If
End Sub