[原创]交点绘制

龙之传人188

看不太懂，要好好学习~~~~~

我爱锦嘟嘟

怎么用啊  菜鸟

lilacchow

mark~~
~~~~~~~~~~~

Excel2119

感谢楼主，认真学习了

banjinjiu

1、在word中画两条线，平行或相交。
2、同时选中两条线。
在VBE中ThisDocument模块中插入以下代码

1. '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
   
2. '* Created By I Love You_Word!@ExcelHome 2005-3-24 15:34:44
   
3. '仅测试于System: Windows NT Word: 10.0 Language: 2052
   
4. '^The Code CopyIn [ThisDocument-ThisDocument]^'
   
5. '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
   
6. Option Explicit
   
7. Sub GetIntersectPoints()
   
8. Dim LineA As Variant, LineB As Variant, A1 As Single, A2 As Single, B1 As Single, B2 As Single
   
9. Dim PointsArray() As Single, X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
   
10. Dim X3 As Single, Y3 As Single, MyPoints As Shape, ParallelX As Byte, ParallelY As Byte
    
11. On Error Resume Next '忽略错误(此处有很大作用)
    
12. With Selection.ShapeRange '选定的图形对象
    
13. If .Count <> 2 Or .Type <> msoLine Then MsgBox "错误的操作!导致出错的原因可能有:" _
    
14. & vbCrLf & "1.没有选定;" & vbCrLf & "2.选定的自选图形不是直线;" _
    
15. & vbCrLf & "3.选定的线条数量超过了二条或者不足二条; " & vbCrLf & _
    
16. "4.其它.", vbOKOnly + vbExclamation, "Microsoft Word": Exit Sub
    
17. Set LineA = .Item(1) '获得其中的对象之一
    
18. Set LineB = .Item(2) '获得其中的对象之二
    
19. With LineA.Nodes '对象一的几何图形
    
20. PointsArray = .Item(1).Points '顶点之一坐标,是个数组
    
21. X1 = PointsArray(1, 1) 'X轴
    
22. Y1 = PointsArray(1, 2) 'Y轴
    
23. PointsArray = .Item(2).Points '顶点之二坐标
    
24. X2 = PointsArray(1, 1) 'X轴
    
25. Y2 = PointsArray(1, 2) 'Y轴
    
26. '判断是否为水平或者垂直线条
    
27. If Y2 = Y1 Then ParallelY = ParallelY + 1: Y3 = Y1
    
28. If X1 = X2 Then ParallelX = ParallelX + 1: X3 = X1
    
29. End With
    
30. '根据直线的定义Y=AX+B分别获得A1和B1值
    
31. A1 = (Y2 - Y1) / (X2 - X1)
    
32. B1 = Y1 - A1 * X1
    
33. With LineB.Nodes '对象一的几何图形
    
34. PointsArray = .Item(1).Points '顶点之一坐标
    
35. X1 = PointsArray(1, 1) 'X轴
    
36. Y1 = PointsArray(1, 2) 'Y轴
    
37. PointsArray = .Item(2).Points '顶点之二坐标
    
38. X2 = PointsArray(1, 1) 'X轴
    
39. Y2 = PointsArray(1, 2) 'Y轴
    
40. If Y2 = Y1 Then ParallelY = ParallelY + 1: Y3 = Y1
    
41. If X1 = X2 Then ParallelX = ParallelX + 1: X3 = X1
    
42. End With
    
43. A2 = (Y2 - Y1) / (X2 - X1)
    
44. B2 = Y1 - A2 * X1
    
45. '提示
    
46. If ParallelY = 2 Then MsgBox "平行的两条水平线条,Word无法找到交点!", _
    
47. vbOKOnly + vbInformation, "Microsoft Word": Exit Sub
    
48. If ParallelX = 2 Then MsgBox "平行的两条垂直线条,Word无法找到交点!", _
    
49. vbOKOnly + vbInformation, "Microsoft Word": Exit Sub
    
50. '如果两线相交 , 其交点位置的X / Y坐标为共有
    
51. If X3 = 0 Then X3 = (B2 - B1) / (A1 - A2)
    
52. If Y3 = 0 Then Y3 = A1 * X3 + B1
    
53. End With
    
54. '定义一个圆形(交点,其半径为1.5磅)
    
55. Set MyPoints = ActiveDocument.Shapes.AddShape(msoShapeOval, X3 - 1.5, Y3 - 1.5, 3, 3)
    
56. With MyPoints
    
57. .Line.ForeColor = wdColorBlack '线条颜色
    
58. .Fill.ForeColor = wdColorBlack '填充色
    
59. .ZOrder msoBringToFront '置于顶层
    
60. End With
    
61. End Sub
    
62. '----------------------

复制代码

运行该代码，则相交的线出现交点，不相交的线出现提示。

leikaiyi123

hxhgxy 发表于 2005-3-24 18:33
守柔兄，给你一个好东西借鉴一下。顺便给你一个“艰巨”的任务，如何使连接线和图形连接很随意，而不必一 ...

我也想知道画两图形连接线的方法，及U形连接线的方法

leikaiyi123

几何中常需标两线夹角的小圆弧或小直角符号，并标角1、角a、角阿尔法等，能升级这个功能就实用了。