VBA提取CAD的表格，别人做了很多类似的
因为没有代码可供复制，某宝上面买了个教程，刚好抄了一段判断选择集是否存在得我函数代码。没什么说的，需要注意的是要保存为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
你好怎么使用啊？？？？ 664571221 发表于 2020-8-3 08:37
你好怎么使用啊？？？？
vbarun 就开始使用了啊，VBA做的都没有命令，一律运行vbarun 不错的插件
感谢楼主分享 感谢楼主分享 谢谢分享！ 2010加载不了 leimw 发表于 2021-10-29 18:50
2010加载不了
2010以后的版本就要安装vba的扩展包了，具体下载链接搜一下论坛 收到，谢谢！
页:
[1]