投稿‎ > ‎

Add Shape At Cursor(zoom)

posted Nov 18, 2018, 2:02 AM by Zhang Wenxu
Option Explicit
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type
Declare Function GetSystemMetrics Lib "user32.dll" _
(ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const DPI As Double = 96#
Const PPI As Double = 72#
Private Const LOGPIXELSX As Long = &H58&
Private Const LOGPIXELSY As Long = &H5A&
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hDc As Long, _
    ByVal nIndex As Long _
    ) As Long
Private Declare Function GetDC Lib "user32" ( _
    ByVal hWnd As Long _
    ) As Long
Private Declare Sub ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal hDc As Long _
    )
Sub addShape()
'
' addShape Macro
'

'
    Dim lngMetricsValueCx As Long, lngMetricsValueCy As Long
  
    lngMetricsValueCx = GetSystemMetrics(SM_CXSCREEN)
    lngMetricsValueCy = GetSystemMetrics(SM_CYSCREEN)
    Debug.Print "Screen: " & lngMetricsValueCx & " * " & lngMetricsValueCy
   
    Dim shp As Shape
    
    'Set Shape = ActiveSheet.Shapes.addShape(msoShapeRectangle, 163.5, 133.5, 52.5, 15.75)
    Debug.Print "ActiveCell: " & ActiveCell.left & "," & ActiveCell.top & "," & ActiveCell.Width & "," & ActiveCell.Height
    Dim llCoord As POINTAPI
    ' Get the cursor positions
    GetCursorPos llCoord
    Debug.Print "X Cursor: " & llCoord.Xcoord & vbNewLine & "Y Cursor: " & llCoord.Ycoord

    Debug.Print "X Position: " & Application.ActiveWindow.PointsToScreenPixelsX(0) _
        + ActiveCell.left * DPI / PPI * (ActiveWindow.Zoom / 100) _
        & vbNewLine & "Y Position: " & Application.ActiveWindow.PointsToScreenPixelsY(0) _
        + ActiveCell.top * DPI / PPI * (ActiveWindow.Zoom / 100)

    'Debug.Print ActiveCell.left * DPI / PPI & "," & ActiveCell.top * DPI / PPI
    Dim p As POINTAPI
    p.Xcoord = (llCoord.Xcoord - Application.ActiveWindow.PointsToScreenPixelsX(0)) _
        * PPI / DPI / (ActiveWindow.Zoom / 100)
    p.Ycoord = (llCoord.Ycoord - Application.ActiveWindow.PointsToScreenPixelsY(0)) _
        * PPI / DPI / (ActiveWindow.Zoom / 100)
    Set shp = ActiveSheet.Shapes.addShape(msoShapeRectangle, p.Xcoord, p.Ycoord, 52.5, 15.75)
End Sub

Private Sub GET_DPI()
    Dim hWnd As Long
    Dim hDc As Long
    hWnd = Excel.Application.hWnd
    hDc = GetDC(hWnd)
    '水平方向DPI
        Debug.Print GetDeviceCaps(hDc, LOGPIXELSX)
    '垂直方向DPI
        Debug.Print GetDeviceCaps(hDc, LOGPIXELSY)
    ReleaseDC hWnd, hDc
End Sub

Comments