123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107 |
- Attribute VB_Name = "arrowtool"
- Public Sub SetArrow()
- Dim s As Shape
- Set s = ActiveShape
- s.name = "arrow"
- End Sub
- Public Sub turn_over()
- Dim sr As ShapeRange, s As Shape
- Set sr = ActiveSelectionRange
-
- For Each s In sr
- s.RotationAngle = s.RotationAngle + 180
- Next s
- End Sub
- Sub arrow_Batch_repalce()
- Dim old As Shape, src As Shape, arrow_set As ShapeRange
- Dim nr As NodeRange
- Dim x1 As Double, y1 As Double
- Dim x2 As Double, y2 As Double
-
- Dim sr As ShapeRange
- Set sr = ActiveSelectionRange
-
- For Each old In sr
- Set nr = old.DisplayCurve.Nodes.All
- x1 = nr(1).PositionX
- y1 = nr(1).PositionY
- x2 = nr(2).PositionX
- y2 = nr(2).PositionY
- Angle = lineangle(x1, y1, x2, y2)
-
- Set src = old.Duplicate(0, 0)
- src.Rotate -Angle
-
- Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
-
- arrow_repalce arrow_set(1), src, Angle
- src.Delete: old.Delete
- Next old
- End Sub
- Sub arrow_repalce(arrow As Shape, src As Shape, ByVal Angle As Double)
- ActiveDocument.Unit = cdrMillimeter
- Set s = arrow.Duplicate(0, 0)
- s.name = "new_arrow"
- s.SizeWidth = src.SizeWidth
- s.SizeHeight = src.SizeHeight
- s.RotationAngle = Angle
- s.CenterX = src.CenterX: s.CenterY = src.CenterY
-
- ' If Angle > 180 Then s.RotationAngle = s.RotationAngle + 180
- End Sub
- Sub arrow_manual_tool()
- Dim old As Shape, src As Shape, arrow_set As ShapeRange
- Dim nr As NodeRange
- Dim x1 As Double, y1 As Double
- Dim x2 As Double, y2 As Double
- Set nr = ActiveShape.Curve.Selection
- Set old = ActiveShape
- x1 = nr(1).PositionX
- y1 = nr(1).PositionY
- x2 = nr(2).PositionX
- y2 = nr(2).PositionY
- Angle = lineangle(x1, y1, x2, y2)
- Set src = old.Duplicate(0, 0)
- ' MsgBox Angle
- src.Rotate -Angle
-
- Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
-
- arrow_repalce arrow_set(1), src, Angle
-
- src.Delete: old.Delete
- End Sub
- ' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
- ' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
- ' VB中用atn(), 返回值是弧度,需要 乘以 PI /180
- Private Function old_lineangle(x1, y1, x2, y2) As Double
- pi = 4 * VBA.Atn(1) ' 计算圆周率
- If x2 = x1 Then
- lineangle = 90: Exit Function
- End If
- lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
- End Function
- Private Function lineangle(x1, y1, x2, y2) As Double
- If x2 = x1 Then lineangle = 90: Exit Function
- pi = 4 * VBA.Atn(1)
- k = (y2 - y1) / (x2 - x1)
- Angle = VBA.Atn(k) * 180 / pi
-
- If k >= 0 Then
- lineangle = Angle
- Else
- lineangle = Angle + 180
- End If
- End Function
|