Excel VBA ComboBox鼠标悬停展开、移开关闭的代码异常求解

问题原因 #

原代码两个异常的核心诱因：

1. MouseMove事件会在鼠标处于控件范围内时随鼠标移动持续触发，没有状态拦截的话会反复发送Alt+↓组合键
2. SendKeys默认是异步执行，选中列表项后焦点跳转到新单元格时，延迟发送的按键会作用在活动单元格上，导致后续悬停失效

核心修复逻辑 #

• 新增模块级布尔标记记录下拉框展开状态，仅在未展开时触发一次展开指令
• 调用Windows API获取鼠标真实屏幕坐标，判断鼠标移出控件范围时自动发送ESC收起下拉，重置状态标记
• 开启SendKeys同步等待模式，配合DoEvents刷新消息队列，避免按键异步发送到错误焦点
• 在选中项跳转单元格的逻辑前提前重置展开标记，阻断误触发链路

完整代码 #

将以下代码放在ComboBox所在的工作表模块（若为窗体控件则放在用户窗体模块）的最顶部：

' 32/64位Office兼容API声明
#If VBA7 Then
    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 ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 模块级状态标记
Private isDropDown As Boolean
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

替换原有MouseMove事件代码：

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim cursorPos As POINTAPI
    Dim screenX As Single, screenY As Single
    Dim dpiX As Single, dpiY As Single
    Dim hDC As LongPtr
    
    ' 仅当下拉未展开时触发一次展开动作
    If Not isDropDown Then
        ComboBox1.Activate
        ' 同步发送按键，等待执行完成后再继续后续逻辑
        SendKeys "%{DOWN}", True
        DoEvents
        isDropDown = True
    End If
    
    ' 检测鼠标是否移出控件范围
    GetCursorPos cursorPos
    hDC = GetDC(0)
    dpiX = GetDeviceCaps(hDC, LOGPIXELSX) / 72
    dpiY = GetDeviceCaps(hDC, LOGPIXELSY) / 72
    ReleaseDC 0, hDC
    
    ' 转换控件坐标为屏幕坐标做范围判断
    screenX = (ComboBox1.Left + ComboBox1.Parent.Left) * dpiX
    screenY = (ComboBox1.Top + ComboBox1.Parent.Top) * dpiY
    If cursorPos.X < screenX Or cursorPos.X > screenX + ComboBox1.Width * dpiX Or _
       cursorPos.Y < screenY Or cursorPos.Y > screenY + ComboBox1.Height * dpiY Then
        ' 鼠标移出，收起下拉并重置标记
        SendKeys "{ESC}", True
        isDropDown = False
    End If
End Sub

在你原有选中项后跳转A列单元格的ComboBox1_Change事件中，新增一行状态重置代码：

Private Sub ComboBox1_Change()
    ' 提前重置展开标记，避免跳转单元格后误触发
    isDropDown = False
    
    ' 下方保留你原有的查找、选中A列对应单元格的代码即可
    ' 示例：Range("A:A").Find(What:=ComboBox1.Value, LookIn:=xlValues).Select
End Sub

注意事项 #

• 若你的系统显示缩放不是100%，代码中做了DPI适配，不会出现坐标判断偏移的问题
• 不要删除DoEvents语句，它是解决SendKeys焦点错位的关键
• 鼠标快速移出控件范围时也能正常触发收起逻辑，不会出现下拉框卡住的情况

内容的提问来源于stack exchange，提问作者2Took