获取鼠标当前位置的单元格或对象信息

楼主 chrisfang	RangeFromPoint函数可以获取某个坐标位置上的单元格或对象，如果配合API函数GetCursorPos，则可以获取鼠标所在位置的单元格或对象信息。此思路并非本人首创，Button和chijanzen等前辈都曾有过相关论述，在此仅对此方法进行进一步的整理总结和改进。由于工作表和工作簿没有MouseMove事件，要想实时地获取鼠标移动后的位置信息，可以借用死循环或用计时器定时反复运行程序来扫描鼠标的移动事件，以牺牲系统资源为代价换取模拟的MouseMove事件。图表对象具有Mouse事件，不需要借用死循环或计时器即可编写出可以根据鼠标位置获取图表内容信息的程序。以下程序根据以上思路编写，点击开始按钮开启扫描状态后，鼠标所在位置的信息可以显示在A1、A2单元格中——如果鼠标所在位置为单元格，则A1、A2单元格分别显示鼠标所在单元格的行号和列号，如果鼠标所在位置为对象（如图形、图表、文本框、艺术字、控件等等），则在A1单元格中显示其名称。方法1：使用Loop循环 Private Declare Function GetCursorPos Lib "user32" (lpPoint As MyPoint) As Long Private Type MyPoint: X As Long: Y As Long: End Type Public flag Sub mousetarget() Dim CurPos As MyPoint Do While flag GetCursorPos CurPos x1 = CurPos.X: y1 = CurPos.Y Set CurRng = ActiveWindow.RangeFromPoint(x1, y1) If CurRng Is Nothing Then Exit Sub On Error Resume Next If TypeName(CurRng) = "Range" Then Range("A1") = CurRng.Row Range("A2") = CurRng.Column Else Range("A1") = CurRng.Name Range("A2") = "" End If DoEvents Loop End Sub Sub startscan() MsgBox "开始" flag = True mousetarget End Sub Sub endscan() MsgBox "结束" flag = False End Sub 附件如下：鼠标位置new.rar
2楼 chrisfang	方法2：借用VBS的重复工作定时器setInterval，方法来源于chijanzen大侠：需要在工作表中增加一个DHTML控件 Private Declare Function GetCursorPos Lib "user32" (lpPoint As MyPoint) As Long Private Type MyPoint: X As Long: Y As Long: End Type Public flag Sub mousetarget() Dim CurPos As MyPoint GetCursorPos CurPos x1 = CurPos.X: y1 = CurPos.Y Set CurRng = ActiveWindow.RangeFromPoint(x1, y1) If CurRng Is Nothing Then Exit Sub On Error Resume Next If TypeName(CurRng) = "Range" Then Range("A1") = CurRng.Row Range("A2") = CurRng.Column Else Range("A1") = CurRng.Name Range("A2") = "" End If End Sub Sub SetTimer() Dim Src As String Src = Src & "<Script Language = VBS>" & vbCrLf Src = Src & "Dim tId, Target, ProcName" & vbCrLf Src = Src & "Sub CallBack()" & vbCrLf Src = Src & " On Error Resume Next" & vbCrLf Src = Src & " Target.Run ProcName" & vbCrLf Src = Src & " On Error GoTo 0" & vbCrLf Src = Src & "End Sub" & vbCrLf Src = Src & "Sub StartTimer(Arg1, Arg2)" & vbCrLf Src = Src & " Set Target = Arg1: ProcName = Arg2" & vbCrLf Src = Src & " If tId <> 0 Then StopTimer " & vbCrLf Src = Src & " tId = Window.setInterval(""CallBack"", 100) " & vbCrLf Src = Src & "End Sub" & vbCrLf Src = Src & "Sub StopTimer()" & vbCrLf Src = Src & " Set Target = Nothing: Window.clearInterval tId" & vbCrLf Src = Src & " tId = 0" & vbCrLf Src = Src & "End Sub" & vbCrLf Src = Src & "</Script>" With ThisWorkbook.Worksheets(1).DHTMLEdit1 .Width = 0: .Height = 0 .DocumentHTML = Src: .BrowseMode = True Do While .Busy: DoEvents: Loop .DOM.Script.StartTimer ThisWorkbook.Application, "mousetarget" End With End Sub Sub startscan() MsgBox "开始" SetTimer End Sub Sub endscan() MsgBox "结束" On Error Resume Next ThisWorkbook.Worksheets(1).DHTMLEdit1.DOM.Script.StopTimer On Error GoTo 0 End Sub 鼠标位置2.rar
3楼 chrisfang	方法3：使用Ontime定时+循环，反复运行。扫描间隔时间较长，需要鼠标停留片刻以后才能显示。 Private Declare Function GetCursorPos Lib "user32" (lpPoint As MyPoint) As Long Private Type MyPoint: X As Long: Y As Long: End Type Public flag Sub mousetarget() Dim CurPos As MyPoint GetCursorPos CurPos x1 = CurPos.X: y1 = CurPos.Y Set CurRng = ActiveWindow.RangeFromPoint(x1, y1) If CurRng Is Nothing Then Exit Sub On Error Resume Next If TypeName(CurRng) = "Range" Then Range("A1") = CurRng.Row Range("A2") = CurRng.Column Else Range("A1") = CurRng.Name Range("A2") = "" End If End Sub Sub startscan() MsgBox "开始" flag = True loopsub End Sub Sub endscan() MsgBox "结束" flag = False End Sub Sub loopsub() If flag = True Then mousetarget Application.OnTime Now + TimeValue("00:00:01"), "loopsub" End If DoEvents End Sub 鼠标位置3.rar
4楼 gvntw	方兄API也学得这么好！