[求助]请教efan老师？我前天发的贴子，可能太隐蔽了。不好意思重发一遍吧

HQ_2003

我看了许多关于Cad与Excel相互连接的问题，大部分都是讲在Cad中提取块属性到Excel中，或者是把Excel表格提取到Cad中。
   
  我现在想做的就是手动选择Cad中的材料表内容动态或是按一定路径输出到Excel中或者是文本文件中，而且输出的内容能按一定规则排序。
   希望斑竹或其它高手能给出一些示例代码，谢了。

efan2000

将块属性导出到Excel，是先获取要导出的块的对象。而导出文字，可以先选择所需要的文字，然后对这样文字进行组织，比如放入到数组中，对数组中的文字排序，最后导出到Excel。
能上传一个附件吗？说明一下排序的方式。

HQ_2003

这方面的原理这两天我也研究了一下。心里也有了个模糊认识。但实际编起程序来总觉得不容易，只能东拼西凑的。最后一运行也总是出错，总觉得不专业。因此来麻烦尹凡老师(不知你的名字是否写对了,我好像在“晓东cad“网站上见过你的名字)
以下是cad做的构件明细表
程序要求：
   1.按cad中的明细表格式输出到excel中(输出后最好能根据所选输出字体大小自动调整excel中列和行的宽度);
   2.输出后以规格一列作为主要关键字，以备注一列作为次要关键字递减排序；
   3.当选择明细表时如果没有全部选中，提示用户能继续窗选余下的内容，并顺序输入到同一个文件中。

[此贴子已经被作者于2003-6-7 19:56:13编辑过]

efan2000

由于明细表不是块形式的，因而文字的处理就比较麻烦，究竟它属于哪一列哪一行的都要自己去处理。
先自己试着编写一下，也可以积累一些经验。

HQ_2003

我绞尽脑汁想了几天， 最后只写了这样一些代码。唉！关键的问题还是没有解决--"按cad中的材料表格式输出",帮我提示一下吧！
  

HQ_2003

efan2000

明细表中的实体全部是单行文字和直线，这种表格的输出是相对麻烦的，因为对于一个表格来说，应该知道文字所在的行和列，而这个最重要的因素却无法直接获取。
有两种方法解决，一是判断文字距明细表内容的左上角点之间，有几条水平直线和垂直直线，那么这个文字就确定了哪一行和哪一列。这要用到选择集，而选择集只能对窗口可视部分的实体操作，因而有可能会出现不可预料的结果，而且检查了一下，有的文字的插入点偏了位置，跑到另一列去了。
二是确定明细表每一行的行高和每一列到明细表内容的左下角点的列宽，然根据文字的插入点，求出文字所在的行和列。
最后输出到Excel，剩下的操作应该借助于Excel的功能来实现了。

efan2000

Option Explicit

Dim iPt As Variant
Dim rh As Double
Dim cw() As Double

Sub test()
    Dim xlApp As Object
    Dim SSetObj As AcadSelectionSet
    Dim fType(0 To 0) As Integer
    Dim fData(0 To 0) As Variant
    Dim EntObj As AcadEntity
    Dim Pt As Variant
   
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        xlApp.workbooks.Add
    End If
    Set SSetObj = ThisDrawing.SelectionSets("MXB")
    If Err.Number <> 0 Then
        Err.Clear
        Set SSetObj = ThisDrawing.SelectionSets.Add("MXB")
    End If
    SSetObj.Clear
   
    On Error GoTo ErrTrap
    Dim xdType As Variant
    Dim xdData As Variant
    ThisDrawing.ModelSpace.GetXData "明细表表体", xdType, xdData
    If IsEmpty(xdType) Then
        Pt = ThisDrawing.Utility.GetPoint(, "指定明细表内容的左上角点: ")
        ReDim xdType(0 To 1) As Integer
        ReDim xdData(0 To 1) As Variant
        xdType(0) = 1001
        xdData(0) = "明细表表体"
        xdType(1) = 1011
        xdData(1) = Pt
        ThisDrawing.ModelSpace.SetXData xdType, xdData
    Else
        Pt = xdData(1)
    End If
    iPt = Pt
    SetRow
    SetColumn
    fType(0) = 0: fData(0) = "Text"
    SSetObj.SelectOnScreen fType, fData
    Dim r As Integer
    Dim c As Integer
    For Each EntObj In SSetObj
        r = GetRow(EntObj)
        c = GetColumn(EntObj)
        If r > 0 And c > 0 Then xlApp.activesheet.cells(r, c) = EntObj.TextString
    Next
    Exit Sub
   
ErrTrap:
    On Error GoTo 0
End Sub

Sub SetRow()
    Dim xdType As Variant
    Dim xdData As Variant
    Dim Dist As Double
   
    On Error GoTo ErrTrap
    ThisDrawing.ModelSpace.GetXData "明细表行高", xdType, xdData
    If IsEmpty(xdType) Then
        Dist = ThisDrawing.Utility.GetDistance(iPt, "指定明细表的行高: ")
        ReDim xdType(0 To 1) As Integer
        ReDim xdData(0 To 1) As Variant
        xdType(0) = 1001
        xdData(0) = "明细表行高"
        xdType(1) = 1040
        xdData(1) = Dist
        ThisDrawing.ModelSpace.SetXData xdType, xdData
    Else
        Dist = xdData(1)
    End If
    rh = Dist
    Exit Sub
   
ErrTrap:
    On Error GoTo 0
End Sub

Sub SetColumn()
    Dim xdType As Variant
    Dim xdData As Variant
    Dim n As Integer
    Dim Dist As Double
   
    On Error GoTo ErrTrap
    ThisDrawing.ModelSpace.GetXData "明细表列宽", xdType, xdData
    If IsEmpty(xdType) Then
        ReDim xdType(0 To 0) As Integer
        ReDim xdData(0 To 0) As Variant
        xdType(0) = 1001
        xdData(0) = "明细表列宽"
        Dist = -1
        Do While Dist <> 0
            Dist = ThisDrawing.Utility.GetDistance(iPt, "指定明细表的列宽: ")
            If Dist <> 0 Then
                n = n + 1
                ReDim Preserve xdType(0 To n) As Integer
                ReDim Preserve xdData(0 To n) As Variant
                xdType(n) = 1040
                xdData(n) = Dist
            End If
        Loop
        ThisDrawing.ModelSpace.SetXData xdType, xdData
    End If
    ReDim cw(0 To UBound(xdType) - 1)
    For n = 1 To UBound(xdType)
        cw(n - 1) = xdData(n)
    Next
    Exit Sub
   
ErrTrap:
    Dist = 0
    Resume Next
    On Error GoTo 0
End Sub

Function GetRow(ByVal EntObj As AcadText) As Integer
    Dim tPt(0 To 2) As Double
    Dim i As Integer
    Dim n As Integer
   
    On Error GoTo ErrTrap
    tPt(0) = EntObj.InsertionPoint(0)
    tPt(1) = EntObj.InsertionPoint(1) + 3
    tPt(2) = 0
    Do While iPt(1) + n * rh < tPt(1)
        n = n + 1
    Loop
    GetRow = n
    Exit Function
   
ErrTrap:
    On Error GoTo 0
End Function

Function GetColumn(ByVal EntObj As AcadText) As Integer
    Dim tPt(0 To 2) As Double
    Dim i As Integer
    Dim n As Integer
   
    On Error GoTo ErrTrap
    tPt(0) = EntObj.InsertionPoint(0) + 5
    tPt(1) = EntObj.InsertionPoint(1)
    tPt(2) = 0
    Do While iPt(0) + cw(n) < tPt(0)
        n = n + 1
    Loop
    GetColumn = n
    Exit Function
   
ErrTrap:
    On Error GoTo 0
End Function
其中，ipt保存了左下角点的坐标，rh保存了明细表的行高，cw数组保存了明细表的列宽（是指这一列与前面所有列的总宽度）。使用了扩展数据保存数据，因而上述的值只在第一次运行时会提示输入。
GetRow和GetColumn用于判断一个文字所在的行和列。
注意输出到Excel里的行顺序是倒着。