[vba]Код
Option Explicit
Type POINT
x As Double
y As Double
End Type
Type VECTOR
v_x As Double
v_y As Double
End Type
Sub test()
Dim shp As Shape, vctRes As VECTOR, i As Integer
For Each shp In ActiveSheet.Shapes
'Stop
i = i + 1
If fGetArrowData(shp, vctRes) Then
With Range("A" & i)
.Value = shp.Name
.Offset(, 1).Value = vctRes.v_x
.Offset(, 2).Value = vctRes.v_y
End With
'''Debug.Print , vctRes.v_y
End If
Next shp
End Sub
Function fGetArrowData(shp As Shape, vctRes As VECTOR) As Boolean
On Error GoTo errHandler
Dim fRet As Boolean
Dim apntDots(0 To 1) As POINT
Dim fNormDirection As Boolean
With shp
If .HorizontalFlip = msoFalse Then
apntDots(0).x = .Left
apntDots(1).x = .Left + .Width
Else
apntDots(0).x = .Left + .Width
apntDots(1).x = .Left
End If
If .VerticalFlip = msoFalse Then
apntDots(0).y = .Top
apntDots(1).y = .Top + .Height
Else
apntDots(0).y = .Top + .Height
apntDots(1).y = .Top
End If
fNormDirection = (.Line.BeginArrowheadStyle = msoArrowheadNone)
End With
With vctRes
.v_x = apntDots(1).x - apntDots(0).x
.v_y = apntDots(1).y - apntDots(0).y
If Not fNormDirection Then
.v_x = -.v_x
.v_y = -.v_y
End If
End With
fRet = True
exitHere:
fGetArrowData = fRet
Exit Function
errHandler:
fRet = False
Resume exitHere
End Function
[/vba]
ps
ось y направлена вниз