|
以前曾做过一个水平与垂直线条相交的交点自动绘制工作，还一个尾巴，那就是任意斜线的交点绘制，没有能够完成。
这是以前的一个贴子链接：http://club.excelhome.net/viewthread.php?tid=59545
今天，总算完成了这个心愿！与网友们共享之！
适用于对两条相交直线的交点自动绘制工作。当然，这个程序中，没有过多涉及修饰性的格式设置，如果需要，可以参考以上链接。
以下代码供参考：
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-3-24 16:02:05
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub GetIntersectPoints()
Dim LineA As Variant, LineB As Variant, A1 As Single, A2 As Single, B1 As Single, B2 As Single
Dim PointsArray() As Single, X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
Dim X3 As Single, Y3 As Single, MyPoints As Shape, ParallelX As Byte, ParallelY As Byte
On Error Resume Next '忽略错误(此处有很大作用)
With Selection.ShapeRange '选定的图形对象
If .Count <> 2 Or .Type <> msoLine Then MsgBox "错误的操作!导致出错的原因可能有:" _
& vbCrLf & "1.没有选定;" & vbCrLf & "2.选定的自选图形不是直线;" _
& vbCrLf & "3.选定的线条数量超过了二条或者不足二条; " & vbCrLf & _
"4.其它.", vbOKOnly + vbExclamation, "Microsoft Word": Exit Sub
Set LineA = .Item(1) '获得其中的对象之一
Set LineB = .Item(2) '获得其中的对象之二
With LineA.Nodes '对象一的几何图形
PointsArray = .Item(1).Points '顶点之一坐标,是个数组
X1 = PointsArray(1, 1) 'X轴
Y1 = PointsArray(1, 2) 'Y轴
PointsArray = .Item(2).Points '顶点之二坐标
X2 = PointsArray(1, 1) 'X轴
Y2 = PointsArray(1, 2) 'Y轴
'判断是否为水平或者垂直线条
If Y2 = Y1 Then ParallelY = ParallelY + 1: Y3 = Y1
If X1 = X2 Then ParallelX = ParallelX + 1: X3 = X1
End With
'根据直线的定义Y=AX+B分别获得A1和B1值
A1 = (Y2 - Y1) / (X2 - X1)
B1 = Y1 - A1 * X1
With LineB.Nodes '对象一的几何图形
PointsArray = .Item(1).Points '顶点之一坐标
X1 = PointsArray(1, 1) 'X轴
Y1 = PointsArray(1, 2) 'Y轴
PointsArray = .Item(2).Points '顶点之二坐标
X2 = PointsArray(1, 1) 'X轴
Y2 = PointsArray(1, 2) 'Y轴
If Y2 = Y1 Then ParallelY = ParallelY + 1: Y3 = Y1
If X1 = X2 Then ParallelX = ParallelX + 1: X3 = X1
End With
A2 = (Y2 - Y1) / (X2 - X1)
B2 = Y1 - A2 * X1
'提示
If ParallelY = 2 Then MsgBox "平行的两条水平线条,Word无法找到交点!", _
vbOKOnly + vbInformation, "Microsoft Word": Exit Sub
If ParallelX = 2 Then MsgBox "平行的两条垂直线条,Word无法找到交点!", _
vbOKOnly + vbInformation, "Microsoft Word": Exit Sub
'如果两线相交 , 其交点位置的X / Y坐标为共有
If X3 = 0 Then X3 = (B2 - B1) / (A1 - A2)
If Y3 = 0 Then Y3 = A1 * X3 + B1
End With
'定义一个圆形(交点,其半径为1.5磅)
Set MyPoints = ActiveDocument.Shapes.AddShape(msoShapeOval, X3 - 1.5, Y3 - 1.5, 3, 3)
With MyPoints
.Line.ForeColor = wdColorBlack '线条颜色
.Fill.ForeColor = wdColorBlack '填充色
.ZOrder msoBringToFront '置于顶层
End With
End Sub
'----------------------
pxNiOizA.zip
(14.49 KB, 下载次数: 217)
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-3-24 16:10
楼主
