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

672277923 · 发表于 2020-8-2 11:42:45

因为没有代码可供复制，某宝上面买了个教程，刚好抄了一段判断选择集是否存在得我函数代码。
没什么说的，需要注意的是要保存为DVB文件，然后再DVB的所在路径下新建一个Excel文件（名为“提取表格”后缀改为xlsm，工作表名为“提取表格”）
直接粘贴代码吧：

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) < pt2(0) Then
SSet.Select acSelectionSetWindow, pt1, pt2, fType, fData
Else
SSet.Select acSelectionSetCrossing, pt1, pt2, fType, fData
End If
Dim ent As AcadLine
Dim hzx() As Double '定义横向直线存放的数组
Dim szx() As Double '定义竖向直线存放的数组
Dim hi As Long '定义横直线数组数
Dim si As Long '定义竖直线数组数
hi = 1
si = 1
'------------获取每条直线的X，Y坐标
For Each ent In SSet
If Round(ent.StartPoint(0), 3) = Round(ent.EndPoint(0), 3) Then '直线X值相等则为竖直线
ReDim Preserve szx(1 To si)
szx(si) = (ent.StartPoint(0) + ent.EndPoint(0)) / 2
si = si + 1
End If
If Round(ent.StartPoint(1), 3) = Round(ent.EndPoint(1), 3) Then '直线Y值相等则为横直线
ReDim Preserve hzx(1 To hi)
hzx(hi) = (ent.StartPoint(1) + ent.EndPoint(1)) / 2
hi = hi + 1
End If
Next
SSet.Delete
Dim i0 As Long
Dim j0 As Long
Dim temp As Double
For i0 = 1 To UBound(szx) - 1 '竖直线从左到右排序
For j0 = i0 + 1 To UBound(szx)
If szx(i0) > 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) < hzx(j0) Then
temp = hzx(j0)
hzx(j0) = hzx(i0)
hzx(i0) = temp
End If
Next j0
Next i0
'-------剔除坐标相同的线，重新组成纵横线坐标
Dim szx1() As Double
Dim hzx1() As Double
ReDim szx1(1 To 1)
szx1(1) = szx(1)
j0 = 1
For i0 = 2 To UBound(szx)
If szx1(j0) <> 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) < pt2(0) Then
SSet1.Select acSelectionSetWindow, pt1, pt2, fType, fData
Else
SSet1.Select acSelectionSetCrossing, pt1, pt2, fType, fData
End If
Dim ent1 As AcadText
Dim wz() As String '定义文字存放的数组
Dim wzsz() As Double '定义文字坐标的数组
Dim i As Long
Dim j As Long
ReDim wz(0 To (SSet1.Count) - 1) As String
ReDim wzsz(1 To (SSet1.Count) * 2) As Double
i = 0
j = 1
'获取文字插入点，以便于判断文字的位置
For Each ent1 In SSet1
wz(i) = ent1.TextString
wzsz(j) = ent1.InsertionPoint(0)
wzsz(j + 1) = ent1.InsertionPoint(1)
i = i + 1
j = j + 2
Next
SSet1.Delete
Dim ii As Long
Dim zhh As Long
zhh = excel.sheets("提取表格").range("A65536").End(3).row + 1
excel.sheets("提取表格").range("A" & zhh) = "提取时间:" & Now()
Stop
For i = 1 To UBound(hzx1) - 1
For j = 1 To UBound(szx1) - 1
For ii = 0 To UBound(wz) '循环文字
If wzsz(ii * 2 + 1) > szx1(j) And wzsz(ii * 2 + 1) < szx1(j + 1) And wzsz(ii * 2 + 2) < hzx1(i) And wzsz(ii * 2 + 2) > 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

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) < pt2(0) Then 
            SSet.Select acSelectionSetWindow, pt1, pt2, fType, fData 
        Else 
            SSet.Select acSelectionSetCrossing, pt1, pt2, fType, fData 
        End If 
         
            Dim ent As AcadLine 
            Dim hzx() As Double '定义横向直线存放的数组 
            Dim szx() As Double '定义竖向直线存放的数组 
            Dim hi As Long '定义横直线数组数 
            Dim si As Long '定义竖直线数组数 
            hi = 1 
            si = 1 
            '------------获取每条直线的X，Y坐标 
                For Each ent In SSet 
                    If Round(ent.StartPoint(0), 3) = Round(ent.EndPoint(0), 3) Then '直线X值相等则为竖直线 
                    ReDim Preserve szx(1 To si) 
                    szx(si) = (ent.StartPoint(0) + ent.EndPoint(0)) / 2 
                    si = si + 1 
                    End If 
                     
                    If Round(ent.StartPoint(1), 3) = Round(ent.EndPoint(1), 3) Then '直线Y值相等则为横直线 
                    ReDim Preserve hzx(1 To hi) 
                    hzx(hi) = (ent.StartPoint(1) + ent.EndPoint(1)) / 2 
                    hi = hi + 1 
                    End If 
                Next 
                SSet.Delete 
Dim i0 As Long 
Dim j0 As Long 
Dim temp As Double 
 
For i0 = 1 To UBound(szx) - 1 '竖直线从左到右排序 
    For j0 = i0 + 1 To UBound(szx) 
        If szx(i0) > 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) < hzx(j0) Then 
            temp = hzx(j0) 
            hzx(j0) = hzx(i0) 
            hzx(i0) = temp 
        End If 
    Next j0 
Next i0 
 
'-------剔除坐标相同的线，重新组成纵横线坐标 
Dim szx1() As Double 
Dim hzx1() As Double 
ReDim szx1(1 To 1) 
    szx1(1) = szx(1) 
    j0 = 1 
    For i0 = 2 To UBound(szx) 
        If szx1(j0) <> 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) < pt2(0) Then 
            SSet1.Select acSelectionSetWindow, pt1, pt2, fType, fData 
        Else 
            SSet1.Select acSelectionSetCrossing, pt1, pt2, fType, fData 
        End If 
            Dim ent1 As AcadText 
            Dim wz() As String '定义文字存放的数组 
            Dim wzsz() As Double '定义文字坐标的数组 
            Dim i As Long 
            Dim j As Long 
            ReDim wz(0 To (SSet1.Count) - 1) As String 
            ReDim wzsz(1 To (SSet1.Count) * 2) As Double 
            i = 0 
            j = 1 
            '获取文字插入点，以便于判断文字的位置 
                For Each ent1 In SSet1 
                    wz(i) = ent1.TextString 
                    wzsz(j) = ent1.InsertionPoint(0) 
                    wzsz(j + 1) = ent1.InsertionPoint(1) 
                    i = i + 1 
                    j = j + 2 
                Next 
            SSet1.Delete 
 
Dim ii As Long 
Dim zhh As Long 
 
zhh = excel.sheets("提取表格").range("A65536").End(3).row + 1 
excel.sheets("提取表格").range("A" & zhh) = "提取时间:" & Now() 
Stop 
For i = 1 To UBound(hzx1) - 1 
    For j = 1 To UBound(szx1) - 1 
        For ii = 0 To UBound(wz) '循环文字 
            If wzsz(ii * 2 + 1) > szx1(j) And wzsz(ii * 2 + 1) < szx1(j + 1) And wzsz(ii * 2 + 2) < hzx1(i) And wzsz(ii * 2 + 2) > 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

664571221 · 发表于 2020-8-3 08:37:34

你好怎么使用啊？？？？

672277923 · 发表于 2020-8-3 11:34:06

664571221 发表于 2020-8-3 08:37
你好怎么使用啊？？？？

vbarun 就开始使用了啊，VBA做的都没有命令，一律运行vbarun

jdzhqddzh · 发表于 2020-8-5 20:52:00

不错的插件

lwb514 · 发表于 2020-9-20 22:27:09

感谢楼主分享

whyyshy · 发表于 2020-9-21 14:49:20

感谢楼主分享

xxchemkin · 发表于 2021-2-24 09:52:54

谢谢分享！

leimw · 发表于 2021-10-29 18:50:35

2010加载不了

672277923 · 发表于 2021-11-1 09:39:04

leimw 发表于 2021-10-29 18:50
2010加载不了

2010以后的版本就要安装vba的扩展包了，具体下载链接搜一下论坛

leimw · 发表于 2021-11-1 16:08:20

收到，谢谢！

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源