求大神修改VBA源程序

305903846

详见图片：

caiqinbin

你VBA源程序呢。。 附件里没有。  原结果与需求结果对比了一下， 也就是列项减少而已，有源码的话改起来很快。

305903846

caiqinbin 发表于 2017-1-21 00:23
你VBA源程序呢。。 附件里没有。  原结果与需求结果对比了一下， 也就是列项减少而已，有源码的话改起来很 ...

Option Explicit
' 属性转化为表格程序
' 明经通道 http://www.mjtd.com
Sub Att2Table()
    On Error Resume Next
    Dim Ent As AcadEntity
    Dim Pnt As Variant
   
    ' 提示选择属性块，并判断块中是否含有属性
    Do
        ThisDrawing.Utility.GetEntity Ent, Pnt, vbCrLf & "请选择要提取属性的块："
        If Err.Number <> 0 Then Exit Sub
        If Ent.ObjectName = "AcDbBlockReference" Then
            If Ent.HasAttributes = True Then
                Exit Do
            End If
        End If
    Loop
    Dim BlkRef As AcadBlockReference
    Set BlkRef = Ent
    Dim BlkName As String
    BlkName = BlkRef.Name
   
    ' 创建空白选择集
    Dim SS As AcadSelectionSet
    Set SS = CreatSSet
   
    ' 设置过滤条件，将所有同名的带属性块过滤出来
    Dim FilterType As Variant
    Dim FilterData As Variant
    Dim FType(2) As Integer
    Dim FData(2) As Variant
    FType(0) = 0
    FData(0) = "INSERT" '图元名
    FType(1) = 66
    FData(1) = 1  '带属性
    FType(2) = 2
    FData(2) = BlkName  '图块名
    FilterType = FType
    FilterData = FData
    SS.Select acSelectionSetAll, , , FilterType, FilterData
   
    Dim i As Integer
    Dim j As Integer
    Dim Blk As AcadBlock
    Dim Att As AcadAttribute
    Dim AttRef As AcadAttributeReference
    Dim AttRefs As Variant
    Dim Rows As Double
    Dim Cols As Double
    Dim Table As AcadTable
   
    ' 遍历选择集中的属性块
    For i = 0 To SS.Count - 1
        Set BlkRef = SS(i)
        AttRefs = BlkRef.GetAttributes
        
        ' 添加表格，并设置表头
        If i = 0 Then
            Cols = UBound(AttRefs) + 1
            Rows = SS.Count
            Dim InsertionPoint As Variant
            InsertionPoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "请选择表格插入点：")
            Set Table = AddBlkTable(InsertionPoint, Cols, Rows)
            Set Blk = ThisDrawing.Blocks(BlkRef.Name)
            
            ' 提取属性定义内容中的提示做为表头
            For Each Ent In Blk
                If Ent.ObjectName = "AcDbAttributeDefinition" Then
                    Set Att = Ent
                    Table.SetText 0, j, Att.PromptString
                    j = j + 1
                End If
            Next
        End If
        
        ' 遍历属性块中的每一属性内容，将属性内容填入表格相应的行中
        For j = 0 To UBound(AttRefs)
            Set AttRef = AttRefs(j)
            Table.SetText i + 1, j, AttRef.TextString
        Next
    Next
End Sub
'按行列数添加表格的函数
Function AddBlkTable(InsertionPoint As Variant, TableColCount As Double, TableRowCount As Double)
    Dim Table As AcadTable
    Dim RowHeight As Double, Colwidth As Double
    RowHeight = 200: Colwidth = 1000 '行高及列宽
    Set Table = ThisDrawing.ModelSpace.AddTable _
                (InsertionPoint, TableRowCount + 1, TableColCount, RowHeight, Colwidth)
    Table.HeaderSuppressed = True
    '取消原先表格格式中的首行合并
    Table.UnmergeCells 0, 0, 0, TableColCount - 1 '按顺序为合并的起始行号、结束行号、起始列号、结束列号
    Table.SetTextHeight 50, 100
    'Table.SetAlignment 3, 5
    Set AddBlkTable = Table
    'Debug.Print Table.Rows
End Function
' 创建空白选择集的函数
Function CreatSSet() As AcadSelectionSet
    On Error Resume Next
    ThisDrawing.SelectionSets("mccad").Delete
    Set CreatSSet = ThisDrawing.SelectionSets.Add("mccad")
End Function

king20061335

请问楼主用的哪个版本的CAD，我可以帮你用.net改写。

305903846

king20061335 发表于 2017-2-5 17:02
请问楼主用的哪个版本的CAD，我可以帮你用.net改写。

AutoCAD 2008 - Simplified Chinese
非常感谢！！！

king20061335

已用C重写，请按附件中的使用说明操作。

305903846

king20061335 发表于 2017-2-10 11:53
已用C重写，请按附件中的使用说明操作。

明天试一下，非常感谢！！！

king20061335

对于发的求助的帖子，如有人帮你解决，是不是应该反馈一下，比如说能不能用，有没有什么问题什么的。

305903846

king20061335 发表于 2017-2-16 19:43
对于发的求助的帖子，如有人帮你解决，是不是应该反馈一下，比如说能不能用，有没有什么问题什么的。

可以使用，也达到了预期的效果，非常感谢！如果是在原基础上修改就更好了！！！