我正在驾驶无人机，并且希望能够通过单击添加箭头来指出图片上的内容。通过单击将添加一个箭头，并且末端将指向最近的角落。单击图片时，将运行宏绘制箭头。代码能够运行（大多数时候），但是我确实有一些问题。
第一个是在原始图片中嵌入箭头，我选择了两张图片并进行复制粘贴操作。然后我删除旧图片和箭头。可能有一种更聪明的方法来做到这一点。有时在将图片粘贴到单元格的操作中会发生错误：错误 1004，Microsoft Excel 无法插入数据。问题出现在 Sub SaveFigure 中，其中图片被移动到图表并保存在外部，以及“ActiveSheet.Pictures.Paste.Select”行的主子 drawArrow 中。
我遇到的另一个问题是我很难避免使用 .select。我试图设置组合图片=一个对象。我不知道如何将它插入到工作表中。有谁知道该怎么做？
如果其他人面临在图片中嵌入数字的相同问题，我已经在下面插入了整个代码。
编辑：我忘记了一些数据类型和函数。他们现在在代码中。
Type RECT
Left As Long: Top As Long: Right As Long: Bottom As Long
End Type
Type POINTAPI
Xcoord As Long: Ycoord As Long
End Type
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Sub drawArrow()
Dim PictureName As String, ArrowName As String, TempName As String
Dim CellLoacation As Collection
Dim Pointlocation As Collection
Dim CellX As Integer, CellY As Integer, CompensateX As Integer, CompensateY As Integer
Dim PicX As Single, PicY As Single, MouseX As Single, MouseY As Single, PicHeight As Single, PicWidth As Single
Dim Arrow As Shape, EditedShape As Shape
Dim strImageName As String
PictureName = shapename
Set CellLoacation = PictureLocatedInCell(PictureName)
CellX = CellLoacation.Item(1) ' the cells x position
CellY = CellLoacation.Item(2) ' the cells y position
PicX = CellLoacation.Item(3) ' the pictures x position
PicY = CellLoacation.Item(4) ' the pictures x position
PicWidth = CellLoacation.Item(5) 'width of the picture
PicHeight = CellLoacation.Item(6) 'Height of the picture
Set Pointlocation = SH03G13(PictureName, CellX, CellY)
MouseX = Pointlocation.Item(1) 'Where the mouse is located at x in pt
MouseY = Pointlocation.Item(2) 'Where the mouse is located at y in pt
CompensateX = ArrowXEndPoint(MouseX, PicWidth) ' Taking zoom into account
CompensateY = ArrowYEndPoint(MouseY, PicHeight) ' Taking zoom into account
Set Arrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, PicX + CompensateX, PicY + CompensateY, PicX + MouseX, PicY + MouseY + Round(CellX / 7, 0))
ArrowName = Arrow.name
Arrow.Line.EndArrowheadStyle = msoArrowheadTriangle
Arrow.ShapeStyle = msoLineStylePreset1
With Arrow.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
ActiveSheet.Shapes.Range(Array(ArrowName, _
PictureName)).Select ' select both arrow and picture
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActiveSheet.Pictures.Paste.Select ' insert picture in sheet - this is where it fails
ActiveSheet.Pictures.OnAction = "drawArrow" ' enable macro
TempName = Selection.name
ActiveSheet.Shapes.Range(Array(ArrowName, _
PictureName)).Select
Selection.Delete' delete old picture and arrow
ActiveSheet.Shapes(TempName).Left = Sheets("Input").Cells(CellX, CellY).Left
ActiveSheet.Shapes(TempName).Top = Sheets("Input").Cells(CellX, CellY).Top
SaveFigure TempName, CellX
End Sub
Sub SaveFigure(TempName, CellX) 'gemmer figuren i en undermappe til hovedmappen
Dim chtObj As ChartObject
S_PATH = Sheets("Data").Range("E1").Value
With ThisWorkbook.Worksheets("Input")
.Activate
Set chtObj = .ChartObjects.add(0, 0, .Shapes(TempName).Width, .Shapes(TempName).Height)
chtObj.name = "TemporaryPictureChart"
'ActiveSheet.Shapes.Range(Array(TempName)).Copy
ActiveSheet.Shapes.Range(Array(TempName)).Select
Selection.Copy
ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
ActiveChart.Paste
ActiveChart.Export fileName:=S_PATH & "\arrowPics\" & Sheets("Input").Cells(CellX, 1), FilterName:="jpg"
chtObj.Delete
End With
End Sub
Function ArrowYEndPoint(MouseY, PicHeight) As Integer ' where to set the end point of the arrow
If (MouseY < PicHeight / 2) Then
If (MouseY < 100) Then
ArrowYEndPoint = 0
Else
ArrowYEndPoint = MouseY - 75
End If
ElseIf (MouseY > PicHeight / 2) Then
If (MouseY > PicHeight - 100) Then
ArrowYEndPoint = PicHeight
Else
ArrowYEndPoint = MouseY + 75
End If
End If
End Function
Function ArrowXEndPoint(MouseX, PicWidth) As Integer where to set the end point of the arrow
If (MouseX < PicWidth / 2) Then
If (MouseX < 100) Then
ArrowXEndPoint = 0
Else
ArrowXEndPoint = MouseX - 75
End If
ElseIf (MouseX > PicWidth / 2) Then
If (MouseX > PicWidth - 100) Then
ArrowXEndPoint = PicWidth
Else
ArrowXEndPoint = MouseX + 75
End If
End If
End Function
Function PictureLocatedInCell(PictureName As String) As Collection ' find picture based on name
Dim PictureToChange As Shape: Set PictureToChange = Sheets("Input").Shapes(shapename)
Dim var As Collection
Set var = New Collection
var.add FindCellBasedOnTop(PictureToChange.Top, PictureToChange.Left)
var.add FindCellBasedOnLeft(PictureToChange.Top, PictureToChange.Left)
var.add PictureToChange.Left
var.add PictureToChange.Top
var.add PictureToChange.Width
var.add PictureToChange.Height
Set PictureLocatedInCell = var
End Function
Function ScreenDPI(bVert As Boolean) As Long
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&)
lDPI(1) = GetDeviceCaps(lDC, 90&)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Function PTtoPX(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Function PXtoPT(Pixels As Long, bVert As Boolean) As Single
PXtoPT = Pixels / (ScreenDPI(bVert) / 72)
End Function
Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window: Set wnd = rng.Parent.Parent.Windows(1)
With rng
rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + rc.Left
rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + rc.Top
End With
End Sub
Function SH03G13(shapename, CellX, CellY) As Collection
Dim wnd As Window
Dim var As Collection
Set var = New Collection
With ThisWorkbook.Sheets("Input")
Dim AreaRng As Range: Set AreaRng = .Range(.Cells(CellX, CellY), .Cells(CellX, CellY))
Dim rectang As Shape: Set rectang = .Shapes(shapename)
'rectang.Height = AreaRng.Height
'rectang.Width = AreaRng.Width
'rectang.Top = AreaRng.Top
'rectang.Left = AreaRng.Left
DoEvents
Dim Point As POINTAPI: GetCursorPos Point
Dim rc As RECT: Call GetRangeRect(.Cells(CellX, CellY), rc)
Dim ABCISSA As Long: ABCISSA = Point.Xcoord - rc.Left
Dim ORDENAD As Long: ORDENAD = Point.Ycoord - rc.Top
End With
'MsgBox "x: " & ABCISSA & ", y: " & ORDENAD
Set wnd = Cells(CellX, CellY).Parent.Parent.Windows(1)
'Debug.Print "Zoom " & wnd.Zoom / 100
var.add PXtoPT(ABCISSA / (wnd.Zoom / 100), 0)
var.add PXtoPT(ORDENAD / (wnd.Zoom / 100), 0)
Set SH03G13 = var
End Function
Function FindCellBasedOnTop(Top, Left) As Integer
FindCellBasedOnTop = Round((Top - Sheets("Input").Rows("1:1").RowHeight) / Sheets("Input").Rows("2:2").RowHeight, 0) + 2
End Function
Function FindCellBasedOnLeft(Top, Left) As Integer
FindCellBasedOnLeft = Round((Left - Sheets("Input").Columns("A").ColumnWidth) / Sheets("Input").Columns("B").ColumnWidth, 0) + 1
End Function
Public Function shapename() As String
Dim ActiveShape As Shape
Dim ButtonName As String 'Get Name of Shape that initiated this macro
ButtonName = Application.Caller
'Set variable to active shape
Set ActiveShape = ActiveSheet.Shapes(ButtonName)
shapename = ActiveShape.name
End Function
如果有什么不清楚的地方请告诉我。
帮助将不胜感激