672277923 发表于 2020-8-2 11:42:00

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)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


**** Hidden Message *****

664571221 发表于 2020-8-3 08:37:00

你好怎么使用啊？？？？

672277923 发表于 2020-8-3 11:34:00


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

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

不错的插件

lwb514 发表于 2020-9-20 22:27:00

感谢楼主分享

whyyshy 发表于 2020-9-21 14:49:00

感谢楼主分享

xxchemkin 发表于 2021-2-24 09:52:00

谢谢分享！

leimw 发表于 2021-10-29 18:50:00

2010加载不了

672277923 发表于 2021-11-1 09:39:00


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

leimw 发表于 2021-11-1 16:08:00

收到，谢谢！
页: [1]
查看完整版本: VBA提取CAD的表格，别人做了很多类似的