求大神修改VBA源程序

305903846 · 发表于 2017-1-16 20:38

详见图片：

caiqinbin · 发表于 2017-1-21 00:23

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

305903846 · 发表于 2017-2-4 11:38

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 · 发表于 2017-2-5 17:02

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

305903846 · 发表于 2017-2-9 21:51

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

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

king20061335 · 发表于 2017-2-10 11:53

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

305903846 · 发表于 2017-2-10 21:23

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

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

king20061335 · 发表于 2017-2-16 19:43

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

305903846 · 发表于 2017-2-17 08:05

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

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

[Auto CAD] 求大神修改VBA源程序

评分