日常工作中，经常需要结地形图进行裁剪，如地形图的分幅，或者在地形图中裁出一块来使用。本文介绍利用AutoCAD二次开发工具VBA进行编程，实现地形图的多边形裁切。

1基础函数

Public filtertype As Variant, filterdata As VariantPublic xy1(0 To 2) As Double, xy2(0 To 2) As DoubleGlobal Const PI As Double = 3.14159265358979Global Const 格式 As String = "0.00"Public Sub acaddoc()'自动运行的宏 acaddocDim MenuGroup0 As AcadMenuGroup'菜单组Dim newMenu As AcadPopupMenu '菜单项Dim newMenuItem As AcadPopupMenuItem'菜单子项On Error Resume NextSet MenuGroup0 = ThisDrawing.Application.MenuGroups.Item(0)Set newMenu = MenuGroup0.Menus.Add("地形图裁切")Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "裁切点状图元", "-vbarun TrimmingPoint" & vbCr)Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "裁切直线", "-vbarun TrimmingLine" & vbCr)Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "裁切折线", "-vbarun TrimmingPLine" & vbCr)Set MenuItem = newMenu.AddSeparator(newMenu.Count + 1)Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "合并裁切命令(保留内部)", "-vbarun 合并裁切命令内" & vbCr)Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "合并裁切命令(保留外部)", "-vbarun 合并裁切命令外" & vbCr)newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1) ' 菜单条上显示菜单End SubFunction VBApath() As StringDim fs, objFileSet fs = CreateObject("Scripting.FileSystemObject")Set objFile = fs.GetFile(ThisDrawing.Application.VBE.ActiveVBProject.FileName)VBApath = objFile.ParentFolder & "\"End Function'计算距离的函数Function 距离(ByVal x1 As Double, ByVal y1 As Double, ByVal z1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal z2 As Double) As Double距离 = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2 + (z1 - z2) ^ 2)End Function'计算距离的函数Function 距离_2P(ByVal Axy As Variant, ByVal Bxy As Variant) As DoubleDim X As Double, Y As Double, Z As DoubleX = Bxy(0) - Axy(0): Y = Bxy(1) - Axy(1)If UBound(Axy) = 2 And UBound(Bxy) = 2 ThenZ = Bxy(2) - Axy(2)ElseZ = 0End If距离_2P = Sqr(X ^ 2 + Y ^ 2 + Z ^ 2)End Function'Public Function 多段线坐标集合(PLine As AcadEntity) As CollectionDim i As Integer, j As IntegerDim pts As New CollectionDim pt(0 To 4) As Double'0-2记录坐标x、y、z;3记录节点到起点的距离;4记录其他信息Dim pt1 As Variantxy = PLine.Coordinatesr = IIf(PLine.ObjectName = "AcDbPolyline", 2, 3)For i = 0 To UBound(xy) Step rpt(0) = xy(i): pt(1) = xy(i + 1): pt(2) = 0If i > 0 Thenpt1 = pts(i / r)pt(3) = pt1(3) + 距离_2P(pt1, pt) '节点到起点的距离End Ifpts.Add ptNextSet 多段线坐标集合 = ptsEnd FunctionPublic Function 点集合转2d序列(pts As Collection) As Double()Dim xyList() As Double, i As IntegerReDim xyList(pts.Count * 2 - 1)Dim pt As VariantFor Each pt In ptsxyList(i) = pt(0)xyList(i + 1) = pt(1)i = i + 2Next点集合转2d序列 = xyListEnd FunctionPublic Function 点集合转3d序列(pts As Collection) As Double()Dim xyList() As Double, i As IntegerReDim xyList(pts.Count * 3 - 1)Dim pt As VariantFor Each pt In ptsxyList(i) = pt(0)xyList(i + 1) = pt(1)xyList(i + 2) = pt(2)i = i + 3Next点集合转3d序列 = xyListEnd FunctionPublic Sub 点集合创建多段线(pts As Collection, Layer As String, Color As Long, Width As Double, Closed As Boolean)Dim xyList() As DoubleDim Polyobj As AcadPolylinexyList = 点集合转3d序列(pts)Set Polyobj = ThisDrawing.ModelSpace.AddPolyline(xyList)Polyobj.Layer = LayerPolyobj.Color = ColorPolyobj.ConstantWidth = WidthPolyobj.Closed = ClosedPolyobj.UpdateEnd SubPublic Sub 点集合创建轻便线(pts As Collection, Layer As String, Color As Long, Width As Double, Closed As Boolean)Dim xyList() As DoubleDim LWpolyline As AcadLWPolylinexyList = 点集合转2d序列(pts)Set LWpolyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(xyList)LWpolyline.Layer = LayerLWpolyline.Color = ColorLWpolyline.ConstantWidth = WidthLWpolyline.Closed = ClosedLWpolyline.UpdateEnd SubFunction 点在线段中间(xyA As Variant, xyB As Variant, xyc As Variant) As BooleanDim a As Double, b As Double, c As Doublec = 距离_2P(xyA, xyB)a = 距离_2P(xyA, xyc)b = 距离_2P(xyB, xyc)If Abs(c - a - b) < 0.0001 Then点在线段中间 = TrueElse点在线段中间 = FalseEnd IfEnd FunctionPublic Function 点在多边形内(pts As Collection, xyP As Variant) As BooleanDim xyA As Variant, xyB As VariantDim xyc(0 To 1) As Double, xyJ(0 To 1) As DoubleDim xyW(0 To 1) As DoubleDim i As Integer, r As IntegerDim 交点数 As Integerxyc(0) = xyP(0) + 100000: xyc(1) = xyP(1)'xyp-xyc 为假定射线xyW(0) = xyP(0): xyW(1) = xyP(1)For i = 1 To pts.Countr = IIf(i = pts.Count, 1, i + 1)xyA = pts(i)xyB = pts(r)'纵坐标不在边(i)两点区间内，边(i)与射线无交点If Abs(xyP(1) - xyA(1)) + Abs(xyP(1) - xyB(1)) <> Abs(xyA(1) - xyB(1)) Then GoTo 50'边(i)与射线平行时，只有当边(i)与射线重合，且横坐标在边(i)两点区间内时才有交点。If xyA(1) = xyB(1) ThenIf xyP(1) = xyB(1) And Abs(xyP(0) - xyA(0)) + Abs(xyP(0) - xyB(0)) = Abs(xyA(0) - xyB(0)) Then 交点数 = 交点数 + 1GoTo 50End If'交点在xyp点的左边，边(i)与射线无交点If 两直线交点(xyA, xyB, xyW, xyc, xyJ) = True ThenIf xyJ(0) >= xyP(0) Then 交点数 = 交点数 + 1End If50: NextIf 交点数 Mod 2 = 0 Then点在多边形内 = FalseElse点在多边形内 = TrueEnd IfEnd FunctionPublic Function 两直线交点(L1sarP As Variant, L1endP As Variant, L2sarP As Variant, L2endP As Variant, Rxy() As Double) As BooleanDim A1 As Double, B1 As Double, C1 As DoubleDim A2 As Double, B2 As Double, C2 As Double, D As DoubleDim xy3(0 To 2) As DoubleA1 = L1endP(0) - L1sarP(0): B1 = L1sarP(1) - L1endP(1): C1 = L1endP(1) * L1sarP(0) - L1sarP(1) * L1endP(0)A2 = L2endP(0) - L2sarP(0): B2 = L2sarP(1) - L2endP(1): C2 = L2endP(1) * L2sarP(0) - L2sarP(1) * L2endP(0)D = A1 * B2 - A2 * B1If Abs(D) < 0.00001 Then两直线交点 = FalseExit FunctionEnd If两直线交点 = TrueRxy(1) = (B1 * C2 - B2 * C1) / DRxy(0) = (C1 * A2 - C2 * A1) / DEnd Function

2点与文字

点和文字如果使用插入点进行判断简单很多，但是，地形图分幅时，有时需保留范围线周边的符号与文字，由人工判断移位或破幅注记。

2.1流程

1）创建一个点与文字的选择集；

2）利用多边形创建一个范围内的点与文字的选择集；

3）计算二个选择集的差集；

4）删除差集内的所有图元。

1.2代码

Sub TrimmingPoint() '裁切点状图元Dim mode As Boolean, n As IntegerDim WPline As AcadEntityDim basePnt As Variantn = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)mode = IIf(n = 1, True, False)ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取Call 点状图元范围修剪(WPline, mode)ThisDrawing.Regen acAllViewports '刷新End SubPublic Sub 点状图元范围修剪(WPline As AcadEntity, mode As Boolean) '符号与文字mode =True时，保留多边形内的图元，删除多边形外的图元。mode =False时，保留多边形外的图元，删除多边形内的图元。Dim FType(0 To 3) As Integer, FData(0 To 3)Dim Lobj(0) As AcadEntityDim 范围内选择集 As AcadSelectionSetDim 全部选择集 As AcadSelectionSetOn Error Resume NextThisDrawing.SelectionSets.Item("全部选择集").DeleteErr.ClearSet 全部选择集 = ThisDrawing.SelectionSets.Add("全部选择集")FType(0) = -4: FData(0) = "<or"FType(1) = 0: FData(1) = "Text"FType(2) = 0: FData(2) = "INSERT"FType(3) = -4: FData(3) = "or>"filtertype = FType: filterdata = FData全部选择集.Select acSelectionSetAll, , , filtertype, filterdata'Debug.Print 全部选择集.Count'2）利用多边形创建一个范围内的点与文字的选择集；ThisDrawing.SelectionSets.Item("范围内选择集").DeleteSet 范围内选择集 = ThisDrawing.SelectionSets.Add("范围内选择集")Dim pts As New CollectionSet pts = 多段线坐标集合(WPline)Dim xyList() As DoublexyList = 点集合转3d序列(pts)范围内选择集.SelectByPolygon acSelectionSetCrossingPolygon, xyList, filtertype, filterdata'Debug.Print 范围内选择集.CountSelect Case modeCase True '保存内部、删除外部对象'全部选择集移出范围内对象For Each Lobj(0) In 范围内选择集全部选择集.RemoveItems LobjNext'Debug.Print 全部选择集.Count'册除全部选择集的对象For Each Lobj(0) In 全部选择集Lobj(0).DeleteNextCase False '保存外部、删除内部对象'册除范围内选择集中的对象For Each Lobj(0) In 范围内选择集Lobj(0).DeleteNextEnd Select范围内选择集.Delete全部选择集.DeleteEnd Sub

3直线

3.1流程

1）创建一个直线的选择集；

2）历遍选择集中的每一根直线与范围线相交，如上图黑色线为范围线，红色线为被剪切直线，直线与范围线有4个交点，形成了5根新的直线。

3）历遍每根新直线，中点是否在范转内。

4)删除原直线

3.2代码

Sub TrimmingLine() '裁切直线Dim mode As Boolean, n As IntegerDim WPline As AcadEntityDim basePnt As Variantn = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)mode = IIf(n = 1, True, False)ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取Call 裁切直线(WPline, mode)ThisDrawing.Regen acAllViewports '刷新End SubPublic Sub 裁切直线(WPline As AcadEntity, mode As Boolean)Dim FType(0) As Integer, FData(0)Dim Lobj As AcadLineDim 直线选择集 As AcadSelectionSetDim n As Integer, i As IntegerDim 交点 As Variant, xy0 As VariantDim Plpts As New CollectionDim pts As New CollectionDim pt(0 To 4) As Double, pt1 As VariantOn Error Resume NextSet Plpts = 多段线坐标集合(WPline)ThisDrawing.SelectionSets.Item("直线选择集").DeleteErr.ClearSet 直线选择集 = ThisDrawing.SelectionSets.Add("直线选择集")FType(0) = 0: FData(0) = "Line"filtertype = FType: filterdata = FData直线选择集.Select acSelectionSetAll, , , filtertype, filterdataFor Each Lobj In 直线选择集交点 = Lobj.IntersectWith(WPline, acExtendNone)'创建直线分段的坐标集合，以点到直线起点的距离进行排序Do While pts.Count > 0pts.Remove Index:=1Loopxy0 = Lobj.StartPointpt(0) = xy0(0): pt(1) = xy0(1): pt(3) = 0pts.Add ptFor n = 0 To UBound(交点) Step 3pt(0) = 交点(n): pt(1) = 交点(n + 1)pt(3) = 距离(xy0(0), xy0(1), 0, 交点(n), 交点(n + 1), 0)For i = 1 To pts.Countpt1 = pts(i)If pt(3) < pt1(3) Thenpts.Add pt, Before:=iGoTo 20End IfNextpts.Add pt20: Nextxy0 = Lobj.EndPointpt(0) = xy0(0): pt(1) = xy0(1)pts.Add ptFor n = 1 To pts.Count - 1pt1 = pts(n)xy1(0) = pt1(0): xy1(1) = pt1(1)pt1 = pts(n + 1)xy2(0) = pt1(0): xy2(1) = pt1(1)Dim xy3(0 To 2) As Doublexy3(0) = (xy1(0) + xy2(0)) / 2xy3(1) = (xy1(1) + xy2(1)) / 2If 点在多边形内(Plpts, xy3) Eqv mode = True ThenDim LineObj As AcadLineSet LineObj = ThisDrawing.ModelSpace.AddLine(xy1, xy2)LineObj.Layer = Lobj.LayerLineObj.Color = Lobj.Color'根据需要，可以设置新直线的其他特性，还可以继承原直线的扩展属性。End IfNextLobj.DeleteNext直线选择集.DeleteEnd Sub

4折线

4.1流程

1）创建一个多段线的选择集；

2）历遍选择集中的每一根多段线与范围线相交

3）把交点插入到多段线的坐标集合中，每二个交点之间为一条新的多段线，如上图，黑色线为范围线，红色线为被剪切线，被剪切线原有8个节点，插入交点后有10个点，形成了三条线。

4）定义关键点：

当交点-交点之间只有二个节点时，如上图中的1-2，关键点为二点的中点

当交点-交点之间多于二个节点时，如上图中的3-8关键点为第二点，即3号点

5）历遍每条新线，用关键点判断新线是否在在范转内

6)删除原折线

4.2代码

Sub TrimmingPLine() '裁切折线Dim mode As Boolean, n As IntegerDim WPline As AcadEntityDim basePnt As Variantn = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)mode = IIf(n = 1, True, False)ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取Call 裁切折线(WPline, mode)ThisDrawing.Regen acAllViewports '刷新End SubPublic Sub 裁切折线(WPline As AcadEntity, mode As Boolean)Dim FType(0) As Integer, FData(0)Dim Lobj As AcadEntityDim 折线选择集 As AcadSelectionSetDim n As Integer, i As Integer, j As IntegerDim 交点 As Variant, xy0 As VariantDim Plpts As New CollectionDim pt(0 To 4) As Double, pt1 As Variant, pt2 As VariantOn Error Resume NextSet Plpts = 多段线坐标集合(WPline)ThisDrawing.SelectionSets.Item("折线选择集").DeleteErr.ClearSet 折线选择集 = ThisDrawing.SelectionSets.Add("折线选择集")FType(0) = 0: FData(0) = "*PolyLine"filtertype = FType: filterdata = FData折线选择集.Select acSelectionSetAll, , , filtertype, filterdataFor Each Lobj In 折线选择集'如果这条线是范围线则跳过If Lobj.Handle = WPline.Handle Then GoTo 100交点 = Lobj.IntersectWith(WPline, acExtendNone)'创建折线分段的坐标集合，以点到折线起点的距离进行排序Dim pts As New CollectionSet pts = 多段线坐标集合(Lobj)'1、无交点：If UBound(交点) < 1 Thenpt2 = pts(1)xy1(0) = pt2(0)xy1(1) = pt2(1)If 点在多边形内(Plpts, xy1) Eqv mode = True ThenGoTo 100 '保留对象ElseGoTo 50 '删除对象End IfEnd If'2、有交点：把交点插入到多段线坐标集合For n = 0 To UBound(交点) Step 3pt(0) = 交点(n): pt(1) = 交点(n + 1)For i = 2 To pts.Countpt1 = pts(i - 1)pt2 = pts(i)If 点在线段中间(pt1, pt2, pt) Thenpt(3) = pt1(3) + 距离_2P(pt1, pt)pt(4) = 1 '标设这个点是分段点For j = 1 To pts.Countpt1 = pts(i)If pt(3) < pt1(3) Thenpts.Add pt, Before:=iGoTo 20End IfNextEnd IfNextpts.Add pt20: NextDim 起点 As Integer, 终点 As IntegerDim 新线 As New Collection起点 = 1For n = 1 To pts.Countpt1 = pts(n)If pt1(4) = 1 Or n = pts.Count Then终点 = nDo While 新线.Count > 0新线.Remove Index:=1LoopFor i = 起点 To 终点pt1 = pts(i)新线.Add pt1Next起点 = 终点'如果新线只有二个点，判断二个点的中点是否在范围内pt1 = 新线(1)pt2 = 新线(2)If 新线.Count = 2 Thenxy1(0) = (pt1(0) + pt2(0)) / 2xy1(1) = (pt1(1) + pt2(1)) / 2Else '如果新线多于二个点，判断第二个点是否在范围内xy1(0) = pt2(0)xy1(1) = pt2(1)End IfIf 点在多边形内(Plpts, xy1) Eqv mode = True ThenSelect Case Lobj.ObjectNameCase "AcDbPolyline"Call 点集合创建多段线(新线, Lobj.Layer, Lobj.Color, Lobj.ConstantWidth, False)Case "AcDbWlPolyline"Call 点集合创建轻便线(新线, Lobj.Layer, Lobj.Color, Lobj.ConstantWidth, False)End SelectEnd If起点 = 终点'根据需要，可以设置新直线的其他特性，还可以继承原直线的扩展属性。End IfNext50: Lobj.Delete100:Next折线选择集.DeleteEnd Sub

5合并裁切命令

Public Sub 合并裁切命令内()Dim WPline As AcadEntityDim basePnt As VariantOn Error Resume NextThisDrawing.Utility.GetEntity WPline, xy, "选取范围线"Call 点状图元范围修剪(WPline, True)Call 裁切直线(WPline, True)Call 裁切折线(WPline, True)ThisDrawing.Regen acAllViewports '刷新End SubPublic Sub 合并裁切命令外()Dim WPline As AcadEntityDim basePnt As VariantOn Error Resume NextThisDrawing.Utility.GetEntity WPline, xy, "选取范围线"Call 点状图元范围修剪(WPline, False)Call 裁切直线(WPline, False)Call 裁切折线(WPline, False)ThisDrawing.Regen acAllViewports '刷新End Sub