1
1

arrowtool.bas 2.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107
  1. Attribute VB_Name = "arrowtool"
  2. Public Sub SetArrow()
  3. Dim s As Shape
  4. Set s = ActiveShape
  5. s.name = "arrow"
  6. End Sub
  7. Public Sub turn_over()
  8. Dim sr As ShapeRange, s As Shape
  9. Set sr = ActiveSelectionRange
  10. For Each s In sr
  11. s.RotationAngle = s.RotationAngle + 180
  12. Next s
  13. End Sub
  14. Sub arrow_Batch_repalce()
  15. Dim old As Shape, src As Shape, arrow_set As ShapeRange
  16. Dim nr As NodeRange
  17. Dim x1 As Double, y1 As Double
  18. Dim x2 As Double, y2 As Double
  19. Dim sr As ShapeRange
  20. Set sr = ActiveSelectionRange
  21. For Each old In sr
  22. Set nr = old.DisplayCurve.Nodes.All
  23. x1 = nr(1).PositionX
  24. y1 = nr(1).PositionY
  25. x2 = nr(2).PositionX
  26. y2 = nr(2).PositionY
  27. Angle = lineangle(x1, y1, x2, y2)
  28. Set src = old.Duplicate(0, 0)
  29. src.Rotate -Angle
  30. Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
  31. arrow_repalce arrow_set(1), src, Angle
  32. src.Delete: old.Delete
  33. Next old
  34. End Sub
  35. Sub arrow_repalce(arrow As Shape, src As Shape, ByVal Angle As Double)
  36. ActiveDocument.Unit = cdrMillimeter
  37. Set s = arrow.Duplicate(0, 0)
  38. s.name = "new_arrow"
  39. s.SizeWidth = src.SizeWidth
  40. s.SizeHeight = src.SizeHeight
  41. s.RotationAngle = Angle
  42. s.CenterX = src.CenterX: s.CenterY = src.CenterY
  43. ' If Angle > 180 Then s.RotationAngle = s.RotationAngle + 180
  44. End Sub
  45. Sub arrow_manual_tool()
  46. Dim old As Shape, src As Shape, arrow_set As ShapeRange
  47. Dim nr As NodeRange
  48. Dim x1 As Double, y1 As Double
  49. Dim x2 As Double, y2 As Double
  50. Set nr = ActiveShape.Curve.Selection
  51. Set old = ActiveShape
  52. x1 = nr(1).PositionX
  53. y1 = nr(1).PositionY
  54. x2 = nr(2).PositionX
  55. y2 = nr(2).PositionY
  56. Angle = lineangle(x1, y1, x2, y2)
  57. Set src = old.Duplicate(0, 0)
  58. ' MsgBox Angle
  59. src.Rotate -Angle
  60. Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
  61. arrow_repalce arrow_set(1), src, Angle
  62. src.Delete: old.Delete
  63. End Sub
  64. ' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
  65. ' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
  66. ' VB中用atn(), 返回值是弧度,需要 乘以 PI /180
  67. Private Function old_lineangle(x1, y1, x2, y2) As Double
  68. pi = 4 * VBA.Atn(1) ' 计算圆周率
  69. If x2 = x1 Then
  70. lineangle = 90: Exit Function
  71. End If
  72. lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
  73. End Function
  74. Private Function lineangle(x1, y1, x2, y2) As Double
  75. If x2 = x1 Then lineangle = 90: Exit Function
  76. pi = 4 * VBA.Atn(1)
  77. k = (y2 - y1) / (x2 - x1)
  78. Angle = VBA.Atn(k) * 180 / pi
  79. If k >= 0 Then
  80. lineangle = Angle
  81. Else
  82. lineangle = Angle + 180
  83. End If
  84. End Function