Я управляю дроном и хотел бы иметь возможность указывать на изображение, добавляя стрелку одним щелчком мыши. При нажатии стрелка будет добавлена и конец будет указывать в сторону ближайшего угла. При нажатии на картинку запускается стрелка макроса. Код может выполняться (чаще всего), однако у меня есть некоторые проблемы.
Изображение окончательного результата, где кончик стрелки вставляется в место мыши при нажатии на изображение
Первый заключается в том, что для встраивания стрелки в исходное изображение я выбираю оба изображения и выполняю операцию копирования и вставки. Затем я удаляю старую картинку и стрелку. Вероятно, есть более разумный способ сделать это. Иногда при вставке изображения в ячейку возникает ошибка: ошибка 1004, Microsoft Excel не может вставить данные. Проблема возникает в Sub SaveFigure, где изображение перемещается на диаграмму и сохраняется внешне, а в основной подпункте drawArrow - в строке "ActiveSheet.Pictures.Paste.Select".
Еще одна проблема, с которой я столкнулся, это большие трудности, чтобы избежать использования .select. Я попытался установить комбинированный рисунок = объект. Я не знаю, как вставить его в листе agian. Кто-нибудь знает, как это сделать?
Я вставил весь код ниже, если другие сталкиваются с той же проблемой вставки рисунков на рисунке.
Редактировать: I забыл некоторые типы данных и функции. Теперь они в коде.
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
Если что-то неясно, пожалуйста, сообщите мне об этом.
Помощь будет высоко оценена