我找到了一些代码来调整“数据验证”消息窗口的大小，但是它是32位的，并且我正在运行64位Excel。我将对Private Declare Function的所有引用更新为Private Declare PtrSafe Function。
现在，代码已超越了所有这些，但出现错误13 Type Mismatch。该代码在标准模块中。
Public Sub StartTimer _
(ByVal MsgTitle As String, ByVal MsgInput As String)
'store the DV imput & title
'messages in global vars.
sInputTitle = MsgTitle
sInputMessage = MsgInput
'initiate SetWindowPos flag.
bFirstCall = True
'timer to run the 'FormatDVMsg' routine.
'required to work async with the Selection_Change
'event.Doesn't put a strain on the system
'as it only runs once upon a cell selection.
lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
End Sub
弹出错误窗口时，代码AddressOf TimerProc的最后一行以蓝色突出显示。
我可能是错的，但我认为代码可以与放在相应工作表模块上的子项一起使用。我之所以这样假设，是因为它们都处理某种计时器。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sTitle As String, sInput As String
On Error Resume Next
'***********************
'shouldn't be necessary
'but just in case.
Set wb = ThisWorkbook
'**********************
sTitle = Target.Validation.InputTitle
sInput = Target.Validation.InputMessage
If Len(sInput & sTitle) <> 0 Then
Call StartTimer(ByVal sTitle, ByVal sInput)
End If
ClearHook
End Sub
除了需要收集某些小知识外，我对VBA一无所知，当我需要完成某些工作时，我几乎会立即忘记，当我再次不使用它时，我会立刻忘记。我不是每天都这样做。如果有人需要帮助，我将在下面发布所有代码。提前致谢。你们真棒！
所有这些操作的目的是更改“数据验证”消息窗口的大小。我尚不知道它是否会起作用，但我希望它会起作用。
在工作表模块中：
Private Sub wb_BeforeClose(Cancel As Boolean)
'safety measure in case
'the wb is not unhooked before closing.
If lPrevWnd Then Call ClearHook
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sTitle As String, sInput As String
On Error Resume Next
'***********************
'shouldn't be necessary
'but just in case.
Set wb = ThisWorkbook
'**********************
sTitle = Target.Validation.InputTitle
sInput = Target.Validation.InputMessage
If Len(sInput & sTitle) <> 0 Then
Call StartTimer(ByVal sTitle, ByVal sInput)
End If
ClearHook
End Sub
在标准模块中：
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 PtrSafe Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe 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 PtrSafe Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare PtrSafe Function GetWindowDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare PtrSafe Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare PtrSafe 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 PtrSafe Function TranslateMessage Lib "user32.dll" _
(ByRef lpMsg As MSG) As Long
Private Declare PtrSafe 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 PtrSafe 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 PtrSafe Function DrawEdge Lib "user32" _
(ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long
Private Declare PtrSafe Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
'========================================
'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)
'=====================================
'User global Constantes.
'Change their values as required.
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
'this is the DV input msg box
'class name in XL 2003.
'not sure about other XL versions.
Private Const DV_INPUT_MSG_CLASS As String = "EXCELA"
'====================================
'Module variables.
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
'==============================
'Global Vars.
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
'build the default brush.
tLB.lbColor = INPUT_BCKG_COLOR
hBrush = CreateBrushIndirect(tLB)
'store the DV dimensions.
GetClientRect hwnd, tClientRect
GetWindowRect hwnd, tWnRect
'intercept the WM_PAINT Msg.
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
'start the text & bckgrnd formatting.
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
'process other msgs.
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)
'send a Paint Msg to the DV box upon showing up.
InvalidateRect lDVhwnd, 0, 0
'important!!!
' Msg pump for safe subclassing !!!!
Call MessageLoop
End If
End Sub
Private Sub MessageLoop()
Dim aMsg As MSG
bXitLoop = False
On Error Resume Next
'ensure all Msgs are posted during the subclassing.
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)
'store the DV imput & title
'messages in global vars.
sInputTitle = MsgTitle
sInputMessage = MsgInput
'initiate SetWindowPos flag.
bFirstCall = True
'timer to run the 'FormatDVMsg' routine.
'required to work async with the Selection_Change
'event.Doesn't put a strain on the system
'as it only runs once upon a cell selection.
lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
End Sub
Public Sub ClearHook()
'cleanUp.
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