AutoCAD VBA二次开发地形图多边形裁剪

最新推荐文章于 2022-12-09 21:59:36 发布

招招有情

最新推荐文章于 2022-12-09 21:59:36 发布

阅读量3k

点赞数 2

分类专栏： CAD二次开发地形图多边形裁切

本文链接：https://blog.csdn.net/jfmyes/article/details/126580404

版权

CAD二次开发同时被 2 个专栏收录

4 篇文章 0 订阅

订阅专栏

地形图多边形裁切

1 篇文章 0 订阅

订阅专栏

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

1基础函数

Public filtertype As Variant, filterdata As Variant
Public xy1(0 To 2) As Double, xy2(0 To 2) As Double
Global Const PI As Double = 3.14159265358979
Global Const 格式 As String = "0.00"

Public Sub acaddoc()               '自动运行的宏  acaddoc
Dim MenuGroup0 As AcadMenuGroup          '菜单组
Dim newMenu As AcadPopupMenu             '菜单项
Dim newMenuItem As AcadPopupMenuItem     '菜单子项
On Error Resume Next
Set 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 Sub

Function VBApath() As String
Dim fs, objFile
Set 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 Double
Dim X As Double, Y As Double, Z As Double
X = Bxy(0) - Axy(0): Y = Bxy(1) - Axy(1)
If UBound(Axy) = 2 And UBound(Bxy) = 2 Then
    Z = Bxy(2) - Axy(2)
Else
    Z = 0
End If
距离_2P = Sqr(X ^ 2 + Y ^ 2 + Z ^ 2)
End Function

'
Public Function 多段线坐标集合(PLine As AcadEntity) As Collection
Dim i As Integer, j As Integer
Dim pts As New Collection
Dim pt(0 To 4) As Double     '0-2记录坐标x、y、z;3记录节点到起点的距离;4记录其他信息
Dim pt1 As Variant
xy = PLine.Coordinates
r = IIf(PLine.ObjectName = "AcDbPolyline", 2, 3)
For i = 0 To UBound(xy) Step r
    pt(0) = xy(i): pt(1) = xy(i + 1): pt(2) = 0
    If i > 0 Then
        pt1 = pts(i / r)
        pt(3) = pt1(3) + 距离_2P(pt1, pt)   '节点到起点的距离
    End If
    pts.Add pt
Next
Set 多段线坐标集合 = pts
End Function

Public Function 点集合转2d序列(pts As Collection) As Double()
Dim xyList() As Double, i As Integer
ReDim xyList(pts.Count * 2 - 1)
Dim pt As Variant
For Each pt In pts
    xyList(i) = pt(0)
    xyList(i + 1) = pt(1)
    i = i + 2
Next
点集合转2d序列 = xyList
End Function

Public Function 点集合转3d序列(pts As Collection) As Double()
Dim xyList() As Double, i As Integer
ReDim xyList(pts.Count * 3 - 1)
Dim pt As Variant
For Each pt In pts
    xyList(i) = pt(0)
    xyList(i + 1) = pt(1)
    xyList(i + 2) = pt(2)
    i = i + 3
Next
点集合转3d序列 = xyList
End Function

Public Sub 点集合创建多段线(pts As Collection, Layer As String, Color As Long, Width As Double, Closed As Boolean)
Dim xyList() As Double
Dim Polyobj As AcadPolyline
xyList = 点集合转3d序列(pts)
Set Polyobj = ThisDrawing.ModelSpace.AddPolyline(xyList)
    Polyobj.Layer = Layer
    Polyobj.Color = Color
    Polyobj.ConstantWidth = Width
    Polyobj.Closed = Closed
    Polyobj.Update
End Sub

Public Sub 点集合创建轻便线(pts As Collection, Layer As String, Color As Long, Width As Double, Closed As Boolean)
Dim xyList() As Double
Dim LWpolyline As AcadLWPolyline
xyList = 点集合转2d序列(pts)
Set LWpolyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(xyList)
    LWpolyline.Layer = Layer
    LWpolyline.Color = Color
    LWpolyline.ConstantWidth = Width
    LWpolyline.Closed = Closed
    LWpolyline.Update
End Sub

Function 点在线段中间(xyA As Variant, xyB As Variant, xyc As Variant) As Boolean
Dim a As Double, b As Double, c As Double
c = 距离_2P(xyA, xyB)
a = 距离_2P(xyA, xyc)
b = 距离_2P(xyB, xyc)
If Abs(c - a - b) < 0.0001 Then
    点在线段中间 = True
Else
    点在线段中间 = False
End If
End Function

Public Function 点在多边形内(pts As Collection, xyP As Variant) As Boolean
Dim xyA As Variant, xyB As Variant
Dim xyc(0 To 1) As Double, xyJ(0 To 1) As Double
Dim xyW(0 To 1) As Double
Dim i As Integer, r As Integer
Dim 交点数 As Integer
xyc(0) = xyP(0) + 100000: xyc(1) = xyP(1)     'xyp-xyc 为假定射线
xyW(0) = xyP(0): xyW(1) = xyP(1)
For i = 1 To pts.Count
    r = 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) Then
       If xyP(1) = xyB(1) And Abs(xyP(0) - xyA(0)) + Abs(xyP(0) - xyB(0)) = Abs(xyA(0) - xyB(0)) Then 交点数 = 交点数 + 1
       GoTo 50
    End If
    
    '交点在xyp点的左边，边(i)与射线无交点
    If 两直线交点(xyA, xyB, xyW, xyc, xyJ) = True Then
        If xyJ(0) >= xyP(0) Then 交点数 = 交点数 + 1
    End If
50: Next
If 交点数 Mod 2 = 0 Then
    点在多边形内 = False
Else
    点在多边形内 = True
End If
End Function

Public Function 两直线交点(L1sarP As Variant, L1endP As Variant, L2sarP As Variant, L2endP As Variant, Rxy() As Double) As Boolean
Dim A1 As Double, B1 As Double, C1 As Double
Dim A2 As Double, B2 As Double, C2 As Double, D As Double
Dim xy3(0 To 2) As Double
A1 = 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 * B1
If Abs(D) < 0.00001 Then
    两直线交点 = False
    Exit Function
End If
两直线交点 = True
Rxy(1) = (B1 * C2 - B2 * C1) / D
Rxy(0) = (C1 * A2 - C2 * A1) / D
End Function

2点与文字

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

2.1流程

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

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

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

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

1.2代码

Sub TrimmingPoint()    '裁切点状图元
Dim mode As Boolean, n As Integer
Dim WPline As AcadEntity
Dim basePnt As Variant
n = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)
mode = IIf(n = 1, True, False)
ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"
'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取
Call 点状图元范围修剪(WPline, mode)
ThisDrawing.Regen acAllViewports   '刷新
End Sub

Public 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 AcadEntity
Dim 范围内选择集 As AcadSelectionSet
Dim 全部选择集 As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets.Item("全部选择集").Delete
Err.Clear
Set 全部选择集 = 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("范围内选择集").Delete
Set 范围内选择集 = ThisDrawing.SelectionSets.Add("范围内选择集")
Dim pts As New Collection
Set pts = 多段线坐标集合(WPline)
Dim xyList() As Double
xyList = 点集合转3d序列(pts)

范围内选择集.SelectByPolygon acSelectionSetCrossingPolygon, xyList, filtertype, filterdata
'Debug.Print 范围内选择集.Count
Select Case mode
       Case True   '保存内部、删除外部对象
            '全部选择集移出范围内对象
            For Each Lobj(0) In 范围内选择集
                 全部选择集.RemoveItems Lobj
            Next
            'Debug.Print 全部选择集.Count
            '册除全部选择集的对象
            For Each Lobj(0) In 全部选择集
                Lobj(0).Delete
            Next
       Case False   '保存外部、删除内部对象
            '册除范围内选择集中的对象
            For Each Lobj(0) In 范围内选择集
                Lobj(0).Delete
            Next
End Select
范围内选择集.Delete
全部选择集.Delete
End Sub

3直线

3.1流程

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

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

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

中点在范围内A	保留范围内的图元B	A Eqv B	动作
True	True	True	创建直线
True	false	false
false	true	false
false	false	true	创建直线

4)删除原直线

3.2代码

Sub TrimmingLine()    '裁切直线
Dim mode As Boolean, n As Integer
Dim WPline As AcadEntity
Dim basePnt As Variant
n = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)
mode = IIf(n = 1, True, False)
ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"
'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取
Call 裁切直线(WPline, mode)
ThisDrawing.Regen acAllViewports   '刷新
End Sub

Public Sub 裁切直线(WPline As AcadEntity, mode As Boolean)
Dim FType(0) As Integer, FData(0)
Dim Lobj As AcadLine
Dim 直线选择集 As AcadSelectionSet
Dim n As Integer, i As Integer
Dim 交点 As Variant, xy0 As Variant
Dim Plpts As New Collection
Dim pts As New Collection
Dim pt(0 To 4) As Double, pt1 As Variant
On Error Resume Next
Set Plpts = 多段线坐标集合(WPline)
ThisDrawing.SelectionSets.Item("直线选择集").Delete
Err.Clear
Set 直线选择集 = ThisDrawing.SelectionSets.Add("直线选择集")
    FType(0) = 0: FData(0) = "Line"
    filtertype = FType: filterdata = FData
直线选择集.Select acSelectionSetAll, , , filtertype, filterdata

For Each Lobj In 直线选择集
    交点 = Lobj.IntersectWith(WPline, acExtendNone)
    '创建直线分段的坐标集合，以点到直线起点的距离进行排序
    Do While pts.Count > 0
        pts.Remove Index:=1
    Loop
    xy0 = Lobj.StartPoint
    pt(0) = xy0(0): pt(1) = xy0(1): pt(3) = 0
    pts.Add pt
    For n = 0 To UBound(交点) Step 3
        pt(0) = 交点(n): pt(1) = 交点(n + 1)
        pt(3) = 距离(xy0(0), xy0(1), 0, 交点(n), 交点(n + 1), 0)
        For i = 1 To pts.Count
            pt1 = pts(i)
            If pt(3) < pt1(3) Then
                pts.Add pt, Before:=i
                GoTo 20
            End If
        Next
        pts.Add pt
20: Next
    xy0 = Lobj.EndPoint
    pt(0) = xy0(0): pt(1) = xy0(1)
    pts.Add pt
    
    For n = 1 To pts.Count - 1
        pt1 = 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 Double
        xy3(0) = (xy1(0) + xy2(0)) / 2
        xy3(1) = (xy1(1) + xy2(1)) / 2
        If 点在多边形内(Plpts, xy3) Eqv mode = True Then
            Dim LineObj As AcadLine
            Set LineObj = ThisDrawing.ModelSpace.AddLine(xy1, xy2)
                LineObj.Layer = Lobj.Layer
                LineObj.Color = Lobj.Color
           '根据需要，可以设置新直线的其他特性，还可以继承原直线的扩展属性。
        End If
    Next
    Lobj.Delete
Next
直线选择集.Delete
End Sub

4折线

4.1流程

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

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

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

4）定义关键点：

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

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

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

关键点在范围内A	保留范围内的图元B	A Eqv B	动作
True	True	True	创建新线
True	false	false
false	true	false
false	false	true	创建新线

6)删除原折线

4.2代码

Sub TrimmingPLine()    '裁切折线
Dim mode As Boolean, n As Integer
Dim WPline As AcadEntity
Dim basePnt As Variant
n = InputBox("1:保留多边形内部；" & vbCrLf & "-1:保留多边形外部；", "请输入保留图元的类型！", 1, 1)
mode = IIf(n = 1, True, False)
ThisDrawing.Utility.GetEntity WPline, basePnt, "选取范围线"
'地形图分幅时，可利用设定条件(图层、颜色等)创建选择集自动获取
Call 裁切折线(WPline, mode)
ThisDrawing.Regen acAllViewports   '刷新
End Sub

Public Sub 裁切折线(WPline As AcadEntity, mode As Boolean)
Dim FType(0) As Integer, FData(0)
Dim Lobj As AcadEntity
Dim 折线选择集 As AcadSelectionSet
Dim n As Integer, i As Integer, j As Integer
Dim 交点 As Variant, xy0 As Variant
Dim Plpts As New Collection
Dim pt(0 To 4) As Double, pt1 As Variant, pt2 As Variant
On Error Resume Next
Set Plpts = 多段线坐标集合(WPline)
ThisDrawing.SelectionSets.Item("折线选择集").Delete
Err.Clear
Set 折线选择集 = ThisDrawing.SelectionSets.Add("折线选择集")
    FType(0) = 0: FData(0) = "*PolyLine"
    filtertype = FType: filterdata = FData
折线选择集.Select acSelectionSetAll, , , filtertype, filterdata

For Each Lobj In 折线选择集
    '如果这条线是范围线则跳过
    If Lobj.Handle = WPline.Handle Then GoTo 100
    交点 = Lobj.IntersectWith(WPline, acExtendNone)
    '创建折线分段的坐标集合，以点到折线起点的距离进行排序
    Dim pts As New Collection
    Set pts = 多段线坐标集合(Lobj)
    '1、无交点：
    If UBound(交点) < 1 Then
         pt2 = pts(1)
         xy1(0) = pt2(0)
         xy1(1) = pt2(1)
         If 点在多边形内(Plpts, xy1) Eqv mode = True Then
             GoTo 100   '保留对象
         Else
             GoTo 50    '删除对象
         End If
    End If
      
    '2、有交点：把交点插入到多段线坐标集合
    For n = 0 To UBound(交点) Step 3
        pt(0) = 交点(n): pt(1) = 交点(n + 1)
        For i = 2 To pts.Count
            pt1 = pts(i - 1)
            pt2 = pts(i)
            If 点在线段中间(pt1, pt2, pt) Then
                pt(3) = pt1(3) + 距离_2P(pt1, pt)
                pt(4) = 1  '标设这个点是分段点
                For j = 1 To pts.Count
                    pt1 = pts(i)
                    If pt(3) < pt1(3) Then
                        pts.Add pt, Before:=i
                        GoTo 20
                    End If
                Next
            End If
        Next
        pts.Add pt
20: Next
    Dim 起点 As Integer, 终点 As Integer
    Dim 新线 As New Collection
    起点 = 1
    For n = 1 To pts.Count
        pt1 = pts(n)
        If pt1(4) = 1 Or n = pts.Count Then
            终点 = n
            Do While 新线.Count > 0
                新线.Remove Index:=1
            Loop
            For i = 起点 To 终点
                pt1 = pts(i)
                新线.Add pt1
            Next
            起点 = 终点
            '如果新线只有二个点，判断二个点的中点是否在范围内
            pt1 = 新线(1)
            pt2 = 新线(2)
            If 新线.Count = 2 Then
                xy1(0) = (pt1(0) + pt2(0)) / 2
                xy1(1) = (pt1(1) + pt2(1)) / 2
            Else  '如果新线多于二个点，判断第二个点是否在范围内
                xy1(0) = pt2(0)
                xy1(1) = pt2(1)
            End If
            If 点在多边形内(Plpts, xy1) Eqv mode = True Then
                Select Case Lobj.ObjectName
                       Case "AcDbPolyline"
                            Call 点集合创建多段线(新线, Lobj.Layer, Lobj.Color, Lobj.ConstantWidth, False)
                       Case "AcDbWlPolyline"
                            Call 点集合创建轻便线(新线, Lobj.Layer, Lobj.Color, Lobj.ConstantWidth, False)
                End Select
            End If
            起点 = 终点
           '根据需要，可以设置新直线的其他特性，还可以继承原直线的扩展属性。
        End If
    Next
50: Lobj.Delete
100:
Next
折线选择集.Delete
End Sub

5合并裁切命令

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


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