鼠标屏幕点位置转换成EXCEl中磅坐标支持冻结缩放

qqhuanxiang

#If VBA7 And Win64 Then

Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As LongPtr) As Long
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If
'鼠标屏幕坐标（x0,y0） 返回对应EXCEl窗口中位置磅（x,y）
Function CellScreenPos(x0 As Long, y0 As Long) As Variant
    Const SplitBarWidth = 6
    Const SplitBarHeight = 6
    Const RoundConst = 0.5000001
    Dim Wn As Window
    Dim hdc As Long, px As Long, py As Long
    Dim x As Double, y As Double '返回鼠标坐标在Excel屏幕中的位置
    Dim dx As Double, dy As Double '相对拆分线的距离
    Dim z As Double, spx As Double, spy As Double
    On Error GoTo ErrorHandler
    hdc = GetDC(0)
    px = GetDeviceCaps(hdc, LOGPIXELSX) '获取屏幕分辨率
    py = GetDeviceCaps(hdc, LOGPIXELSY) '获取屏幕分辨率
    ReleaseDC 0, hdc: hdc = 0
    Set Wn = ActiveWindow
    z = Wn.Zoom / 100 'Excel缩放因子
    spx = Wn.SplitHorizontal * px / 72 + RoundConst '垂直拆分线和Excel窗口左边距离
    spy = Wn.SplitVertical * py / 72 + RoundConst '水平拆分线和Excel窗口上边距离
    If Application.Version >= 12 Then
         ppx = ActiveWindow.Panes(1).PointsToScreenPixelsX(0) 'Excel坐标原点
         ppy = ActiveWindow.Panes(1).PointsToScreenPixelsY(0) 'Excel坐标原点
    Else
         ppx = ActiveWindow.PointsToScreenPixelsX(0) 'Excel坐标原点
         ppy = ActiveWindow.PointsToScreenPixelsY(0) 'Excel坐标原点
    End If
    dx = x0 - ppx - Cells(Wn.Panes(1).ScrollRow, Wn.Panes(1).ScrollColumn).Left * px * z / 72 - spx
    dy = y0 - ppy - Cells(Wn.Panes(1).ScrollRow, Wn.Panes(1).ScrollColumn).Top * py * z / 72 - spy
    If dx > 0 Then If Not Wn.FreezePanes Then x = x - SplitBarWidth '如果拆分线未冻结
    If dy > 0 Then If Not Wn.FreezePanes Then y = y - SplitBarHeight '如果拆分线未冻结
    Select Case Sgn(Wn.SplitVertical) * 2 + Sgn(Wn.SplitHorizontal)
        Case 0
                x = x0 - ppx
                y = y0 - ppy
        Case 2 '水平
            If dy >= 0 Then
                x = x0 - ppx
                y = y + dy + Cells(Wn.Panes(2).ScrollRow, Wn.Panes(2).ScrollColumn).Top * py * z / 72
            Else
                x = x0 - ppx
                y = y0 - ppy
            End If
        Case 1 '垂直
            If dx >= 0 Then
                x = x + dx + Cells(Wn.Panes(2).ScrollRow, Wn.Panes(2).ScrollColumn).Left * px * z / 72
                y = y0 - ppy
            Else
                x = x0 - ppx
                y = y0 - ppy
            End If
        Case 3 '水平垂直
            If dy >= 0 And dx < 0 Then
                 x = x0 - ppx
                 y = y + dy + Cells(Wn.Panes(3).ScrollRow, Wn.Panes(3).ScrollColumn).Top * py * z / 72
            ElseIf dy >= 0 And dx >= 0 Then
                 x = x + dx + Cells(Wn.Panes(4).ScrollRow, Wn.Panes(4).ScrollColumn).Left * px * z / 72
                 y = y + dy + Cells(Wn.Panes(4).ScrollRow, Wn.Panes(4).ScrollColumn).Top * py * z / 72
            End If
            If dy < 0 And dx < 0 Then
                 x = x0 - ppx
                 y = y0 - ppy
            ElseIf dy < 0 And dx >= 0 Then
                 x = x + dx + Cells(Wn.Panes(2).ScrollRow, Wn.Panes(2).ScrollColumn).Left * px * z / 72
                 y = y0 - ppy
            End If
    End Select
    x = x * 72 / (px * z)
    y = y * 72 / (py * z)
    CellScreenPos = Array(x, y)
    Exit Function
ErrorHandler:
    If hdc <> 0 Then ReleaseDC 0, hdc
    Exit Function
End Function

qqhuanxiang

测试.zip (18.29 KB, 下载次数: 63)

2015-2-7 15:08 上传

点击文件名下载附件

liucqa

好像有点小问题

1、缩小比例之后，位置偏左了
2、2013下，从400%点击滚动条缩小窗口比例，会发现工作表上也出现点了，大概是识别的问题。

支持一下，争取完善！

qqhuanxiang

有点偏移不是程序本身问题，而是excel提供的ActiveWindow.Zoom的问题在缩小过程中理论上磅/像素是不变的，而实测的磅/像素是不同的，这就说明缩小过程中Zoom值是近视值，如果要在缩小过程中也能准确，那么需要采样实际的缩放比例来代替ActiveWindow.Zoom这个值

qqhuanxiang

分享下我理解的Excel坐标系统

liucqa

qqhuanxiang 发表于 2015-2-10 12:04
有点偏移不是程序本身问题，而是excel提供的ActiveWindow.Zoom的问题在缩小过程中理论上磅/像素是不变的，而 ...

应该有解决办法的

qqhuanxiang

经过修正ActiveWindow.Zoom测试程序提供在此。请测试，应该是精确定位到一个像素 测试.zip (20.21 KB, 下载次数: 41)

2015-2-28 11:45 上传

点击文件名下载附件

zanjero

厉害 收藏一下 学习了

liucqa

qqhuanxiang 发表于 2015-2-28 11:45
经过修正ActiveWindow.Zoom测试程序提供在此。请测试，应该是精确定位到一个像素

第二个问题没解决

qqhuanxiang

liucqa 发表于 2015-2-28 23:02
第二个问题没解决

这只是个测试程序，你是否需要如下效果

Function test() '测试程序鼠标左键开始右键停止
    Dim lngCurPos As POINTAPI
    On Error Resume Next
    Dim scalefact As Variant
    scalefact = okzoom(x, y)
    EnableHook
    GetCursorPos lngCurPos
    If ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.y) Is Nothing Then Exit Function '点工作表区域外，程序不打点？
    Dim pp As Variant
    pp = CellScreenPos(lngCurPos.x, lngCurPos.y, scalefact(0), scalefact(1))
    Set shp = ActiveSheet.Shapes.AddShape(9, pp(0) - 0.5, pp(1) - 0.5, 1, 1)
   
End Function