AutoCAD VBA多重延伸

AutoCAD VBA多重延伸，将多条直线延伸至同一条直线，代码如下。

Public Sub MultiExtend()
Dim number As Integer
Dim ObjSelectionSet As AcadSelectionSet
number = ThisDrawing.SelectionSets.Count
While i < number
Set ObjSelectionSet = ThisDrawing.SelectionSets.Item(0)
ObjSelectionSet.Delete
i = i + 1
Wend
Set ObjSelectionSet = ThisDrawing.SelectionSets.Add("SSET")
ThisDrawing.Utility.Prompt "请选择作为边界的直线："
ObjSelectionSet.SelectOnScreen
While ObjSelectionSet.Item(0).ObjectName <> "AcadLine"
ObjSelectionSet.Item(0).Delete
ThisDrawing.Utility.Prompt "没有选择任何对象，或者不是直线对象，请重新选择："
ObjSelectionSet.SelectOnScreen
Wend
Dim Line As AcadLine
Dim PtCorner01, PtCorner02 As Variant
Set Line = ThisDrawing.SelectionSets.Item(0)
ThisDrawing.Utility.Prompt vbCr & "请选择两个角点定义要延长的对象集合："
PtCorner01 = ThisDrawing.Utility.GetPoint(, "请选择第一点：")
PtCorner02 = ThisDrawing.Utility.GetPoint(, "请选择第二点：")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "Line"
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
ssetObj.Select acSelectionSetCrossing, PtCorner01, PtCorner02, groupCode, dataCode
Dim n As Integer
Dim linea As AcadLine
Dim PtInter As Variant
n = ObjSelectionSet.Count
While n > 1
Set linea = ObjSelectionSet.Item(n - 1)
PtInter = linea.IntersectWith(Line, acExtendBoth)
If PtToLine(linea.StartPoint, Line.StartPoint, Line.EndPoint) > PtToLine(linea.EndPoint, Line.StartPoint, Line.EndPoint) Then
linea.EndPoint = PtInter
Set linea = ObjSelectionSet.Item(n - 1)
PtInter = linea.IntersectWith(Line, acExtendBoth)
If PtToLine(linea.StartPoint, Line.StartPoint, Line.EndPoint) > PtToLine(linea.EndPoint, Line.StartPoint, Line.EndPoint) Then
linea.EndPoint = PtInter
Else
linea.StartPoint = PtInter
End If
n = n - 1
Wend
End Sub
Function Distance(Pt1, Pt2 As Variant) As Double
Distance = ((Pt1(0) - Pt2(0)) ^ 2 + Pt1(1) - Pt2(1)) ^ 0.5
End Function
Function PtToLine(Pt, PtStart, PtEnd As Variant) As Double
Dim sysOSMODE As Integer
Dim PtInter As Variant
Dim linep, linet As AcadLine
Set linet = ThisDrawing.ModelSpace.AddLine(PtStart, PtEnd)
sysOSMODE = ThisDrawing.GetVariable("osmode")
ThisDrawing.SetVariable "osmode", 128
Set linep = ThisDrawing.ModelSpace.AddLine(Pt, linet, StartPoint)
PtToLine = Distance(linep.StartPoint, linep.EndPoint)
linep.de
linet.Delete
ThisDrawing.SetVariable "osmode", sysOSMODE
End Function

代码完。