[VBA程序]：提取cad表格到excel,源码公开

mountains3

本程序是本人接触cad以来一直在做的东东，不断的完善，当我程序的功能还不满意的时候,一直在网上找truetable这个软件，对里面的变编程原理非常感兴趣，现在随着在名经通道得到efan2000,lzh741206斑竹的帮助，终于实现了自己的程序功能，愿公布自己的源码，使很多象我一样对原理感兴趣的朋友心中释然，并在实际的工作中随心所欲编写出满足自己要求的程序，
本程序设定了两个控制变量，根据变量的值确定程序的执行路线，
tablescale确定当采用固定表格格式时，表格的比例
judgeselectp的取值决定用户决定是自己选择点还是采用固定的表格格式
还有一直形式就是在用户选择了所要转换的文字时，完全智能化，这样的功能我在microstation vba的编程中已经实现，在本程序的基础上实现也相当容易，但考虑到这种方法没有什么实际的意义，所以在cad里面没有做这个工作,希望对大家有帮助！
Option Explicit
Public Sub bestt()
'link excel
Dim appexcel As Excel.Application
Dim worksheets As Excel.worksheets
Dim workbooks As Excel.workbooks
Dim workbook As Excel.workbook
Dim worksheet As Excel.worksheet
Dim worksheetname As String
Dim rowscount As Integer
Dim porline As Integer
Dim multinum As Integer
Dim mapserial As String
'worksheetname = InputBox("please enter the worksheetname:")
multinum = Val(InputBox("请输入倍数:"))
If multinum = 0 Then multinum = 1
mapserial = InputBox("请输入图纸号:")
On Error Resume Next
    Set appexcel = GetObject(, "excel.Application")
    '如果错误，启动新的EXCEL实例
If Err Then
        Err.Clear
    Set appexcel = CreateObject("excel.Application")
    Set workbooks = appexcel.workbooks
    Set workbook = workbooks.Add
    Set worksheet = workbook.ActiveSheet
    '如果EXCEL已经运行，关联用户输入的工作表
Else
    Set workbook = appexcel.ActiveWorkbook
    If worksheetname = "" Then
    Set worksheet = workbook.ActiveSheet
    Else
    Set worksheet = workbook.Sheets(worksheetname)
    End If
    '如果工作表不存在，添加工作表
    If Err Then
    Err.Clear
    Set worksheet = workbook.Sheets.Add()
    worksheet.Name = worksheetname
    End If
End If
    rowscount = worksheet.range("a1").CurrentRegion.rows.count
Dim selectcount, objectcount, i, j, k, m, N, yesnotableline As Integer
Dim result, result1, controlp As Variant
Dim text As AcadText
Dim entity As AcadEntity
Dim selects As AcadSelectionSet
Dim restrictp As New Collection
ThisDrawing.SelectionSets.Item("r").Delete
If Err Then
Set selects = ThisDrawing.SelectionSets.Add("r")
Err.Clear
End If
'define filter
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, dataCode As Variant
    gpCode(0) = 0
    dataValue(0) = "text"
    groupCode = gpCode
    dataCode = dataValue
  Dim judgeselectp As Integer
Dim pointarray As Variant
Dim tablescale As Double
'tablescale = ThisDrawing.Utility.GetReal("please enter the table scale")
tablescale = 25
If tablescale = 0 Then tablescale = 1
pointarray = Array(0, 11.82, 71.82, 81.82, 94.82, 111.82, 126.82, 141.82, 179.85)
judgeselectp = 0
If judgeselectp = 1 Then
    On Error GoTo errorhandle
    Do While Not Err
    controlp = ThisDrawing.Utility.GetPoint(, "选择点:")
    restrictp.Add controlp(0)
    Loop
    Else
    controlp = ThisDrawing.Utility.GetPoint(, "选择点:")
    restrictp.Add controlp(0) + pointarray(0) * tablescale
    For i = 1 To UBound(pointarray)
    restrictp.Add controlp(0) + pointarray(i) * tablescale
    Next i
End If
    'End Select
errorhandle:
    'MsgBox "ok?"
    On Error Resume Next
    ThisDrawing.Utility.Prompt "请选择所要转换的文本"
selects.SelectOnScreen groupCode, dataCode
objectcount = selects.count
Dim colectionobj As New Collection
Dim colectionxt As New Collection
Dim colectionx As New Collection
Dim colectiony As New Collection
Dim colectionxb As New Collection
Dim colectionxf As New Collection
Dim textheight As Double
Dim maxrownum As Integer
Dim sort As New Collection
Dim p1, p2, p3, p4
textheight = selects(1).height
For Each text In selects
colectionobj.Add text
Next text
selects.Delete
Set sort = Sort2(colectionobj, textheight)
Dim kkk1, kkk2 As Double
For i = 1 To sort.count
For m = 1 To restrictp.count - 1
For Each j In sort(i)
p2 = j.InsertionPoint
kkk1 = restrictp(m)
kkk2 = restrictp(m + 1)
If restrictp(m) < p2(0) And p2(0) < restrictp(m + 1) Then
If Not worksheet.Cells(i, m) = "" Then
worksheet.Cells(i + rowscount, m) = worksheet.Cells(i + rowscount, m) & " " & j.TextString
Else
worksheet.Cells(i + rowscount, m) = j.TextString
End If
End If
Next j
Next m
worksheet.Cells(i + rowscount, 9) = multinum
worksheet.Cells(i + rowscount, 10) = mapserial
Next i
'Application.WindowState = acMin
'appexcel.Visible = True
'workbook.Activate
'appexcel.WindowState = xlMaximized
End Sub
Public Function Sort2(Texts As Variant, textheight As Double) As Collection
'将选择集、Text数组或Text集合按X轴和Y轴进行排序，返回一个集合的集合
Dim total As New Collection
Dim pPnts As Collection
Dim Judge As Boolean
Dim i As AcadObject, j As Collection, k As Integer, l As Integer
Dim p1, p2, p3, p4
For Each i In Texts
    Judge = False
    For Each j In total
    p1 = j(1).InsertionPoint: p2 = i.InsertionPoint
        If Abs(p1(1) - p2(1)) < textheight Then
            For k = 1 To j.count
            p3 = j(k).InsertionPoint
                If p3(0) >= p2(0) Then
                    j.Add i, , k
                    Judge = True
                    Exit For
                End If
            Next k
            If Not Judge Then j.Add i: Judge = True
            Exit For
        End If
    Next j
    If Not Judge Then
        Set pPnts = New Collection
        pPnts.Add i
        For l = 1 To total.count
            p4 = total(l)(1).InsertionPoint
            If p4(1) < p2(1) Then
                total.Add pPnts, , l
                Judge = True
                Exit For
            End If
        Next l
        If Not Judge Then total.Add pPnts
    End If
Next i
Set Sort2 = total
End Function

gucci218

提示：编译错误，用户定义类型未定义

CADghost

Dim appexcel As Excel.Application
编译错误：用户定义类型未定义

purplebamboo

是不是没有引用辞典！

山里路人

非常感谢楼主，另外，楼主能否大致讲下truetable中的“变编程原理”，truetable那么贵，楼主是怎么知道它的原理的呢，我也想学，多谢了！

mountains3

不可否认,truetable是一个做的比较成熟的软件，很多方面考虑的比较细致。我记得truetable的作者曾经在明经通道发表过一个帖子，大意是“vc玩转excel”,它对excel和cad对象的操作只要你熟悉excel和cad的对象模型，原理很容易想到
至于turetable的整个程序框架,你的熟悉objectarx编程，在此基础上多用用此软件，你就会从正面推测出程序的实现方法，如果你只是像我一样只熟悉vb或vba参照上述代码也是可以编出满足你工作需要的程序的.

mountains3

提示出错的原因是因为要引用excel库，可以在vbaide的工具－－引用菜单下看看是否有缺失的库，然后选择你电脑上正确的库就可以了
结果不出来有两个原因
一是程序中有个变量tablescale,我设的是tablescale=25,你可以修改这个比例
二是程序中有个变量控制是否允许用户自己选择点以确定列的宽度
你只要能把程序读懂，就能正确使用了
good luck!

adisonmaster

真是好东西，终于找到了，不知道比我自己写的程序有什么区别！

yanjun_lyg

最初由 adisonmaster 发布
[B]真是好东西，终于找到了，不知道比我自己写的程序有什么区别！ [/B]

把你的也奉献出来，让我们学习一下，多谢！！

jx2008

改称lisp的程序更好些！