VBA提取CAD的表格，别人做了很多类似的

Option Explicit
Public excelapp As Object
Public excel As Object
Public lj As String
Public Function createSSet() As AcadSelectionSet
    On Error Resume Next
    If Not IsNull(ThisDrawing.SelectionSets.Item("mySelectionSet")) Then
        Set createSSet = ThisDrawing.SelectionSets.Item("mySelectionSet")
        createSSet.Delete
    End If
    Set createSSet = ThisDrawing.SelectionSets.Add("mySelectionSet")
End Function
Public Sub tqbg()
Dim lj As String
Dim ex As Object
    lj = VBA.Left(ThisDrawing.Application.VBE.ActiveVBProject.FileName, InStr(ThisDrawing.Application.VBE.ActiveVBProject.FileName, "\提取") - 1) & "\提取表格.xlsm"
Set excel = GetObject(lj)
Dim SSet As AcadSelectionSet '线条
Dim SSet1 As AcadSelectionSet '文字
MsgBox "请注意：" & vbCr & "1、本功能仅仅支持由直线(Line)和单行文字(Text)构成的表格，如有其它图元，请重复分解命令(Explode),直到无法再次分解为止" & vbCr & vbCr & "2、表格必须横平竖直，不能有斜线" & vbCr & vbCr & "3、格子里面的单行文字插入点必须在格子以内，不然会计算错误" & vbCr & vbCr & "以上任意一个条件不满足均会导致提取表格错位或者失败，请严格按要求提取！！！"
Dim pt1 As Variant
Dim pt2 As Variant
    pt1 = ThisDrawing.Utility.GetPoint(, "选择要提取的区域角点1:")
    pt2 = ThisDrawing.Utility.GetCorner(pt1, "选择要提取的区域角点2:")
    
Dim fType(0) As Integer
Dim fData(0) As Variant
    fType(0) = 0: fData(0) = "LINE"
    Set SSet = createSSet()
        If pt1(0)  szx(j0) Then
            temp = szx(j0)
            szx(j0) = szx(i0)
            szx(i0) = temp
        End If
    Next j0
Next i0
For i0 = 1 To UBound(hzx) - 1 '横直线从上往下排序
    For j0 = i0 + 1 To UBound(hzx)
        If hzx(i0)  szx(i0) Then
        j0 = j0 + 1
        ReDim Preserve szx1(1 To j0)
        szx1(j0) = szx(i0)
        End If
    Next i0
    
    ReDim hzx1(1 To 1)
    hzx1(1) = hzx(1)
    j0 = 1
    For i0 = 2 To UBound(hzx)
        If hzx1(j0)  hzx(i0) Then
        j0 = j0 + 1
        ReDim Preserve hzx1(1 To j0)
        hzx1(j0) = hzx(i0)
        End If
    Next i0
    
'------------逐个判断文字插入点是否在纵横直线范围内
    fType(0) = 0: fData(0) = "TEXT"
        Set SSet1 = createSSet()
        If pt1(0)  szx1(j) And wzsz(ii * 2 + 1)  hzx1(i + 1) Then
                If excel.sheets("提取表格").cells(i + zhh, j)  "" Then
                    excel.sheets("提取表格").cells(i + zhh, j) = wz(ii) & " " & excel.sheets("提取表格").cells(i + zhh, j)
                Else
                    excel.sheets("提取表格").cells(i + zhh, j) = wz(ii)
                End If
            End If
        Next ii
    Next j
Next i
Set excel = Nothing
MsgBox "提取完毕" & vbCr & "本小软件由绛花洞主设计" & vbCr & "如有疑问请联系QQ：672277923"
End Sub