我正在尝试使用 winapi 调用在 VBA 中创建工具提示，基本上遵循 MSDN 中的教程，使用 Declare 语句重新映射到 VBA 等。对
CreateWindowsEx()NULLGetLastError()CreateWindowsEx()这是完整的代码片段：
Private Type INITCOMMONCONTROLSEX_REC
dwSize As Long
dwICC As Long
End Type
Private Const ICC_WIN95_CLASSES = &HFF
Private Declare PtrSafe Function InitCommonControlsEx Lib "Comctl32.dll" (ByRef icce As INITCOMMONCONTROLSEX_REC) As Long
Private Const WS_EX_TOPMOST As Long = &H8
Private Const WS_POPUP As Long = &H80000000
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_NOPREFIX As Long = &H2
Private Const TOOLTIPS_CLASS = "tooltips_class32"
Private Declare PtrSafe Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (dwExStyle As Long, lpClassName As String, lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, _
ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Public Sub CreateToolTip()
Dim ret As Long
Dim retLng As LongPtr
Dim iccRec As INITCOMMONCONTROLSEX_REC
iccRec.dwSize = LenB(iccRec)
iccRec.dwICC = ICC_WIN95_CLASSES
ret = InitCommonControlsEx(iccRec)
Dim hWndTip As LongPtr
hWndTip = CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, vbNullString, _
WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP, _
0, 0, 0, 0, 0, 0, 0, ByVal 0)
End Sub
我大约 10 年前写了一个课程，现在仍然有效，也许你可以尝试一下并根据你的需要进行更改。您可以检查并查看它到底做了什么。
将新的类模块插入您的 VBA 项目并命名为
ToolTipOption Explicit
Private Type LOGFONT 'to use with CreateFontIndirect function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd183500%28v=vs.85%29.aspx)
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
Private Type RECT 'rectangle type
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI '2D cartezian point
X As Long
Y As Long
End Type
Private Type LOGBRUSH 'to use with CreateBrushIndirect API function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd183487%28v=vs.85%29.aspx)
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type PAINTSTRUCT 'to use with BeginPaint, EndPaint API functions
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type
Private Enum WND_STYLES 'Window Styles (https://msdn.microsoft.com/en-gb/library/windows/desktop/ms632600(v=vs.85).aspx)
WS_BORDER = &H800000
WS_CAPTION = &HC00000
WS_CHILD = &H40000000
WS_CLIPCHILDREN = &H2000000
WS_CLIPSIBLINGS = &H4000000
WS_DISABLED = &H8000000
WS_DLGFRAME = &H400000
WS_GROUP = &H20000
WS_HSCROLL = &H100000
WS_MAXIMIZE = &H1000000
WS_MINIMIZE = &H20000000
WS_OVERLAPPED = &H0&
WS_POPUP = &H80000000
WS_SYSMENU = &H80000
WS_TABSTOP = &H10000
WS_THICKFRAME = &H40000
WS_VISIBLE = &H10000000
WS_VSCROLL = &H200000
End Enum
Private Enum ECS 'Edit Control Styles (https://msdn.microsoft.com/en-us/library/windows/desktop/bb775464%28v=vs.85%29.aspx)
ES_AUTOHSCROLL = &H80
ES_AUTOVSCROLL = &H40
ES_CENTER = &H1
ES_LEFT = &H0
ES_LOWERCASE = &H10
ES_MULTILINE = &H4
ES_NOHIDESEL = &H100
ES_OEMCONVERT = &H400
ES_PASSWORD = &H20
ES_READONLY = &H800
ES_RIGHT = &H2
ES_UPPERCASE = &H8
ES_WANTRETURN = &H1000
End Enum
Private Enum EXT_WND_STYLES 'Extended Window Styles (https://msdn.microsoft.com/en-gb/library/windows/desktop/ff700543(v=vs.85).aspx)
WS_EX_ACCEPTFILES = &H10
WS_EX_APPWINDOW = &H40000
WS_EX_CLIENTEDGE = &H200
WS_EX_COMPOSITED = &H2000000
WS_EX_CONTEXTHELP = &H400
WS_EX_CONTROLPARENT = &H10000
WS_EX_DLGMODALFRAME = &H1
WS_EX_LAYERED = &H80000
WS_EX_LAYOUTRTL = &H400000
WS_EX_LEFT = &H0
WS_EX_LEFTSCROLLBAR = &H4000
WS_EX_LTRREADING = &H0
WS_EX_MDICHILD = &H40
WS_EX_NOACTIVATE = &H8000000
WS_EX_NOINHERITLAYOUT = &H100000
WS_EX_NOPARENTNOTIFY = &H4
WS_EX_NOREDIRECTIONBITMAP = &H200000
WS_EX_RIGHT = &H1000
WS_EX_RIGHTSCROLLBAR = &H0
WS_EX_RTLREADING = &H2000
WS_EX_STATICEDGE = &H20000
WS_EX_TOOLWINDOW = &H80
WS_EX_TOPMOST = &H8
WS_EX_TRANSPARENT = &H20
WS_EX_WINDOWEDGE = &H100
WS_EX_OVERLAPPEDWINDOW = WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE
WS_EX_PALETTEWINDOW = WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW Or WS_EX_TOPMOST
End Enum
Private Enum DRAWTEXT_FORMAT 'to use for DrawText function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd162498%28v=vs.85%29.aspx)
DT_TOP = &H0
DT_LEFT = &H0
DT_CENTER = &H1
DT_RIGHT = &H2
DT_VCENTER = &H4
DT_BOTTOM = &H8
DT_WORDBREAK = &H10
DT_SINGLELINE = &H20
DT_EXPANDTABS = &H40
DT_TABSTOP = &H80
DT_NOCLIP = &H100
DT_EXTERNALLEADING = &H200
DT_CALCRECT = &H400
DT_NOPREFIX = &H800
DT_INTERNAL = &H1000
End Enum
Private Enum BK_MODE 'background mode to use with SetBkMode function (https://msdn.microsoft.com/en-us/library/windows/desktop/dd162965(v=vs.85).aspx)
TRANSPARENT = 1
OPAQUE = 2
End Enum
Private Enum CHARSET
ANSI_CHARSET = 0
ARABIC_CHARSET = 178
BALTIC_CHARSET = 186
CHINESEBIG5_CHARSET = 136
DEFAULT_CHARSET = 1
EASTEUROPE_CHARSET = 238
GREEK_CHARSET = 161
HANGUL_CHARSET = 129
HEBREW_CHARSET = 177
JOHAB_CHARSET = 130
MAC_CHARSET = 77
OEM_CHARSET = 255
RUSSIAN_CHARSET = 204
SHIFTJIS_CHARSET = 128
SYMBOL_CHARSET = 2
THAI_CHARSET = 222
TURKISH_CHARSET = 162
End Enum
Private Enum DRAW_ICON_FLAG 'to use with DrawIconEx function (https://msdn.microsoft.com/en-us/library/windows/desktop/ms648065(v=vs.85).aspx)
DI_COMPAT = &H4
DI_DEFAULTSIZE = &H8
DI_IMAGE = &H2
DI_MASK = &H1
DI_NOMIRROR = &H10
DI_NORMAL = 3 'DI_IMAGE and DI_MASK
End Enum
Private Enum BORDER
BDR_RAISEDOUTER = &H1
BDR_SUNKENOUTER = &H2
BDR_RAISEDINNER = &H4
BDR_SUNKENINNER = &H8
BDR_OUTER = &H3
BDR_INNER = &HC
BDR_RAISED = &H5
BDR_SUNKEN = &HA
End Enum
Private Enum EDGE
EDGE_RAISED = BDR_RAISEDOUTER Or BDR_RAISEDINNER
EDGE_SUNKEN = BDR_SUNKENOUTER Or BDR_SUNKENINNER
EDGE_ETCHED = BDR_SUNKENOUTER Or BDR_RAISEDINNER
EDGE_BUMP = BDR_RAISEDOUTER Or BDR_SUNKENINNER
End Enum
Private Enum EDGE_FLAG
BF_LEFT = &H1
BF_TOP = &H2
BF_RIGHT = &H4
BF_BOTTOM = &H8
BF_TOPLEFT = (BF_TOP Or BF_LEFT)
BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
BF_DIAGONAL = &H10
BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
BF_MIDDLE = &H800 ' Fill in the middle
BF_SOFT = &H1000 ' Use for softer buttons
BF_ADJUST = &H2000 ' Calculate the space left over
BF_FLAT = &H4000 ' For flat rather than 3-D borders
BF_MONO = &H8000 ' For monochrome borders
End Enum
Private Const SC_EDIT = "Edit" 'System Classes (https://msdn.microsoft.com/en-gb/library/windows/desktop/ms633574(v=vs.85).aspx#system)
'
'API functions
#If VBA7 Then
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hDC As LongPtr, qrc As RECT, ByVal EDGE As Long, ByVal grfFlags As Long) As Long
Private 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
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
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 Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function DrawIconEx Lib "user32" (ByVal hDC As LongPtr, ByVal xLeft As Long, ByVal yTop As Long, _
ByVal hIcon As LongPtr, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, _
ByVal hbrFlickerFreeDraw As LongPtr, ByVal diFlags As Long) As Long
#Else
Private Declare Function BeginPaint Lib "User32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd 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 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 EndPaint Lib "User32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) 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 GetClientRect Lib "User32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (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 ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, _
ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, _
ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
#End If
'handles
#If VBA7 Then
Private m_hWndToolTip As LongPtr 'handle for window
Private m_hDCToolTip As LongPtr 'handle for device context
Private m_hIcon As LongPtr 'handle for Icon
#Else
Private m_hWndToolTip As Long
Private m_hDCToolTip As Long
Private m_hIcon As Long
#End If
'primary class members
Private m_objParent As Object
Private m_font As LOGFONT
Private m_strMessage As String
'position and size
Private m_sngLeft As Single
Private m_sngTop As Single
Private m_sngWidth As Single
Private m_sngHeight As Single
Private m_sngOffsetFromCursorX As Single
Private m_sngOffsetFromCursorY As Single
Private m_sngTextOffsetLeft As Single
Private m_sngTextOffsetTop As Single
Private m_sngTextOffsetRight As Single
Private m_sngTextOffsetBottom As Single
Private m_sngIconLeft As Single
Private m_sngIconTop As Single
Private m_sngIconWidth As Single
Private m_sngIconHeight As Single
'visibility
Private m_bVisible As Boolean
'auto resize
Private m_bAutoResize As Boolean
'custom types variables
Private m_tClientAreaRect As RECT
Private m_tLogBrush As LOGBRUSH
'Class constructor with default values
Private Sub Class_Initialize()
'position, size and visibility
m_sngLeft = 0
m_sngTop = 0
m_sngWidth = 100
m_sngHeight = 100
m_sngOffsetFromCursorX = 0
m_sngOffsetFromCursorY = 0
m_sngTextOffsetLeft = 10
m_sngTextOffsetTop = 10
m_sngTextOffsetRight = 10
m_sngTextOffsetBottom = 10
m_sngIconLeft = 0
m_sngIconTop = 0
m_sngIconWidth = 0
m_sngIconHeight = 0
m_strMessage = vbNullString
m_bVisible = False
m_bAutoResize = False
'font
With m_font
.lfFaceName = "Arial" & chr(0)
.lfHeight = 16
.lfWidth = 6
.lfEscapement = 0
.lfWeight = 0
.lfItalic = 0
.lfUnderline = 0
.lfStrikeOut = 0
.lfCharSet = CHARSET.DEFAULT_CHARSET
'.lfOutPrecision
'.lfClipPrecision
'.lfQuality
'.lfPitchAndFamily
End With
m_tLogBrush.lbColor = &HE1FFFF 'the usual back color (bright yellow)
'create toolTip window (child of desktop) and get the window handle
'Make it work for both AutoCAD and Excel
#If VBA7 Then
Dim hWndApp As LongPtr
#Else
Dim hWndApp As Long
#End If
If InStr(LCase(Application.Name), "autocad") > 0 Then
hWndApp = Application.hwnd
ElseIf InStr(LCase(Application.Name), "excel") > 0 Then
#If VBA7 Then
hWndApp = Application.HinstancePtr
#Else
hWndApp Application.hInstance
#End If
Else
MsgBox "ToolTip class is not set to retrive the Handle for this application!", vbCritical, "hWnd"
Exit Sub
End If
m_hWndToolTip = CreateWindowEx(EXT_WND_STYLES.WS_EX_TOOLWINDOW, SC_EDIT, vbNullString, _
ECS.ES_MULTILINE + ECS.ES_LEFT + ECS.ES_READONLY + WND_STYLES.WS_CHILD, _
0, 0, 0, 0, GetDesktopWindow, 0, hWndApp, 0)
'
'get the Device Context handle for the toolTip window
m_hDCToolTip = GetDC(m_hWndToolTip)
End Sub
Private Sub Class_Terminate()
'release device context
ReleaseDC m_hWndToolTip, m_hDCToolTip
'destroy toolTip window
DestroyWindow m_hWndToolTip
End Sub
Public Property Get Parent() As Object
Set Parent = m_objParent
End Property
Public Property Let Parent(ByVal objParent As Object)
Set m_objParent = objParent
End Property
Public Property Get Left() As Single
Left = m_sngLeft
End Property
Public Property Let Left(ByVal sngLeft As Single)
m_sngLeft = sngLeft
Call Position(m_sngLeft, m_sngTop)
End Property
Public Property Get Top() As Single
Top = m_sngTop
End Property
Public Property Let Top(ByVal sngTop As Single)
m_sngTop = sngTop
Call Position(m_sngLeft, m_sngTop)
End Property
Public Property Get Width() As Single
Width = m_sngWidth
End Property
Public Property Let Width(ByVal sngWidth As Single)
m_sngWidth = sngWidth
End Property
Public Property Get Height() As Single
Height = m_sngHeight
End Property
Public Property Let Height(ByVal sngHeight As Single)
m_sngHeight = sngHeight
End Property
Public Property Get TextOffsetLeft() As Single
TextOffsetLeft = m_sngTextOffsetLeft
End Property
Public Property Let TextOffsetLeft(ByVal sngTextOffsetLeft As Single)
m_sngTextOffsetLeft = sngTextOffsetLeft
End Property
Public Property Get TextOffsetTop() As Single
TextOffsetTop = m_sngTextOffsetTop
End Property
Public Property Let TextOffsetTop(ByVal sngTextOffsetTop As Single)
m_sngTextOffsetTop = sngTextOffsetTop
End Property
Public Property Get TextOffsetRight() As Single
TextOffsetRight = m_sngTextOffsetRight
End Property
Public Property Let TextOffsetRight(ByVal sngTextOffsetRight As Single)
m_sngTextOffsetRight = sngTextOffsetRight
End Property
Public Property Get TextOffsetBottom() As Single
TextOffsetBottom = m_sngTextOffsetBottom
End Property
Public Property Let TextOffsetBottom(ByVal sngTextOffsetBottom As Single)
m_sngTextOffsetBottom = sngTextOffsetBottom
End Property
Public Property Get BackColor() As Long
BackColor = m_tLogBrush.lbColor
End Property
Public Property Let BackColor(ByVal lngBackColor As Long)
m_tLogBrush.lbColor = lngBackColor
End Property
Public Property Get Message() As String
Message = m_strMessage
End Property
Public Property Let Message(ByVal strMessage As String)
Select Case strMessage
Case vbNullString
Call Hide
Exit Property
Case m_strMessage
If m_bVisible Then Exit Property
Case Else
m_strMessage = strMessage
End Select
'
'declare font
#If VBA7 Then
Dim lngFontHWnd As LongPtr
Dim lngOldFontHWnd As LongPtr
#Else
Dim lngFontHWnd As Long
Dim lngOldFontHWnd As Long
#End If
'
Call show
'create new font object
lngFontHWnd = CreateFontIndirect(m_font)
'remember old font while replacing with new font
lngOldFontHWnd = SelectObject(m_hDCToolTip, lngFontHWnd)
'get client rectangle
GetClientRect m_hWndToolTip, m_tClientAreaRect
'autoResize by text
If m_bAutoResize Then
'get the text rectangle (nothing is drawn by using DT_CALCRECT)
DrawText m_hDCToolTip, m_strMessage, Len(m_strMessage), m_tClientAreaRect, DRAWTEXT_FORMAT.DT_NOCLIP + _
DRAWTEXT_FORMAT.DT_LEFT + DRAWTEXT_FORMAT.DT_CALCRECT
'resize toolTip window
With m_tClientAreaRect
m_sngWidth = .Right - .Left + m_sngTextOffsetLeft + m_sngTextOffsetRight
m_sngHeight = .Bottom - .Top + m_sngTextOffsetTop + m_sngTextOffsetBottom
End With
SetWindowPos m_hWndToolTip, 0, m_sngLeft, m_sngTop, m_sngWidth, m_sngHeight, 0
'get client new rectangle
GetClientRect m_hWndToolTip, m_tClientAreaRect
End If
'draw the colored rectangle into DC
Call DrawRect
'draw the edge of the rectangle
DrawEdge m_hDCToolTip, m_tClientAreaRect, EDGE.EDGE_RAISED, EDGE_FLAG.BF_RECT
'set background before text placing
SetBkMode m_hDCToolTip, BK_MODE.TRANSPARENT
'resize rectangle for placing text and offset-ing text rectangle from main colored rectangle
With m_tClientAreaRect
.Left = .Left + m_sngTextOffsetLeft
.Top = .Top + m_sngTextOffsetTop
.Right = .Right - m_sngTextOffsetRight
.Bottom = .Bottom - m_sngTextOffsetBottom
End With
'draw the text
DrawText m_hDCToolTip, m_strMessage, Len(m_strMessage), m_tClientAreaRect, DRAWTEXT_FORMAT.DT_NOCLIP + DRAWTEXT_FORMAT.DT_LEFT
'selected object [oldFont] releases the previous object of the same type in the Device Context (no memory leaks)
Call SelectObject(m_hDCToolTip, lngOldFontHWnd)
'delete new font object
DeleteObject lngFontHWnd
'draw icon
If m_hIcon <> 0 Then
DrawIconEx m_hDCToolTip, 5, 5, m_hIcon, 16, 16, 0, 0, DRAW_ICON_FLAG.DI_NORMAL
End If
End Property
Public Sub OffsetFromCursor(ByVal sngOffsetFromCursorX As Single, ByVal sngOffsetFromCursorY As Single)
m_sngOffsetFromCursorX = sngOffsetFromCursorX
m_sngOffsetFromCursorY = sngOffsetFromCursorY
End Sub
Public Sub Position(ByVal X As Single, ByVal Y As Single)
m_sngLeft = X + m_sngOffsetFromCursorX
m_sngTop = Y + m_sngOffsetFromCursorY
SetWindowPos m_hWndToolTip, 0, m_sngLeft, m_sngTop, m_sngWidth, m_sngHeight, 0
End Sub
Public Sub PositionByMouse()
Dim mouseXY As POINTAPI
GetCursorPos mouseXY
Position mouseXY.X, mouseXY.Y
End Sub
Public Sub show()
If Not m_bVisible Then
Call ShowWindow(m_hWndToolTip, 1)
m_bVisible = True
End If
End Sub
Public Sub Hide()
If m_bVisible Then
Call ShowWindow(m_hWndToolTip, 0)
m_bVisible = False
End If
End Sub
Public Sub DrawRect()
Dim tPS As PAINTSTRUCT
'declare brush
#If VBA7 Then
Dim lngBrush As LongPtr
#Else
Dim lngBrush As Long
#End If
'
On Error Resume Next
'begin paint
BeginPaint m_hWndToolTip, tPS
'create a new brush
lngBrush = CreateBrushIndirect(m_tLogBrush)
'fill the device context of the toolTip window with the newly created brush inside the client rectangle
FillRect m_hDCToolTip, m_tClientAreaRect, lngBrush
'delete the brush
Call DeleteObject(lngBrush)
'end paint
Call EndPaint(m_hWndToolTip, tPS)
End Sub
Public Property Get Font_Height() As Long
Font_Height = m_font.lfHeight
End Property
Public Property Let Font_Height(ByVal lngFont_Height As Long)
m_font.lfHeight = lngFont_Height
End Property
Public Property Get Font_Width() As Long
Font_Width = m_font.lfWidth
End Property
Public Property Let Font_Width(ByVal lngFont_Width As Long)
m_font.lfWidth = lngFont_Width
End Property
Public Property Get Font_Text_Rotation() As Long
Font_Text_Rotation = m_font.lfEscapement
End Property
Public Property Let Font_Text_Rotation(ByVal lngFontTextRotation As Long)
m_font.lfEscapement = lngFontTextRotation
End Property
Public Property Get Font_Orientation() As Long
Font_Orientation = m_font.lfOrientation
End Property
Public Property Let Font_Orientation(ByVal lngFont_Orientation As Long)
m_font.lfOrientation = lngFont_Orientation
End Property
Public Property Get Font_Italic() As Boolean
Font_Italic = CBool(m_font.lfItalic)
End Property
Public Property Let Font_Italic(ByVal bFontItalic As Boolean)
m_font.lfItalic = CByte(bFontItalic)
End Property
Public Property Get Font_Underline() As Boolean
Font_Underline = CBool(m_font.lfUnderline)
End Property
Public Property Let Font_Underline(ByVal bFontUnderline As Boolean)
m_font.lfUnderline = CByte(bFontUnderline)
End Property
Public Property Get Font_StrikeOut() As Boolean
Font_StrikeOut = CBool(m_font.lfStrikeOut)
End Property
Public Property Let Font_StrikeOut(ByVal bFontStrikeOut As Boolean)
m_font.lfStrikeOut = CByte(bFontStrikeOut)
End Property
#If VBA7 Then
Public Property Let IconHandle(ByVal lngHandle As LongPtr)
m_hIcon = lngHandle
End Property
Public Property Get IconHandle() As LongPtr
IconHandle = m_hIcon
End Property
#Else
Public Property Let IconHandle(ByVal lngHandle As Long)
m_hIcon = lngHandle
End Property
Public Property Get IconHandle() As Long
IconHandle = m_hIcon
End Property
#End If
Public Property Get IconLeft() As Single
IconLeft = m_sngIconLeft
End Property
Public Property Let IconLeft(ByVal sngIconLeft As Single)
m_sngIconLeft = sngIconLeft
End Property
Public Property Get IconTop() As Single
IconTop = m_sngIconTop
End Property
Public Property Let IconTop(ByVal sngIconTop As Single)
m_sngIconTop = sngIconTop
End Property
Public Property Get IconWidth() As Single
IconWidth = m_sngIconWidth
End Property
Public Property Let IconWidth(ByVal sngIconWidth As Single)
m_sngIconWidth = sngIconWidth
End Property
Public Property Get IconHeight() As Single
IconHeight = m_sngIconHeight
End Property
Public Property Let IconHeight(ByVal sngIconHeight As Single)
m_sngIconHeight = sngIconHeight
End Property
Public Property Get AutoResize() As Boolean
AutoResize = m_bAutoResize
End Property
Public Property Let AutoResize(ByVal bAutoResize As Boolean)
m_bAutoResize = bAutoResize
End Property
这是一个简单的测试代码。将其添加到标准代码模块中：
Option Explicit
Private m_toolTip As ToolTip
Sub TestToolTip()
Set m_toolTip = New ToolTip
With m_toolTip
.AutoResize = True
.OffsetFromCursor 30, 0
.PositionByMouse
.Message = .Left & ", " & .Top & vbNewLine & "These are the mouse coordinates!"
End With
End Sub
Sub TestToolTip2()
If m_toolTip Is Nothing Then TestToolTip
m_toolTip.Message = Join(Split("Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.", ". "), "." & vbNewLine)
End Sub
Sub TerminateTooltip()
Set m_toolTip = Nothing
End Sub
当您运行两个测试程序之一时，将会出现一个工具提示。当您运行终止程序时，工具提示将消失。
您当然可以在用户窗体或图表上有一个控制鼠标移动事件，或者可能是一个计时器，使工具提示移动并一直更新，但我相信您能够适应它