投稿‎ > ‎

Add Shape At Cursor

posted Nov 18, 2018, 1:50 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 Long = 96
Const PPI As Long = 72

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 _
        & vbNewLine & "Y Position: " & Application.ActiveWindow.PointsToScreenPixelsY(0) _
        + ActiveCell.top * DPI / PPI

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

Comments