社区 › Auto Lisp › 提取特定块

tazzzz 发表于 2022-7-6 22:13:05

提取特定块

你好
我有一个excel宏，它将带有属性的块从打开的acad dwg中提取到excel电子表格中。
我需要您的帮助来修改此代码，以便能够做到这一点：
-在行代码中指定要提取的块的名称
-指定将提取每个块的列。
我使用AutoCAD 2011和excel 2010
下面是excel VBA代码。
谢谢你的帮助。
Public acad As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
   Dim sheet As Object
   Dim shapes As Object
   Dim elem As Object
   Dim excel As Object
   Dim Max As Integer
   Dim Min As Integer
   Dim NoOfIndices As Integer
   Dim excelSheet As Object
   Dim RowNum As Integer
   Dim Array1 As Variant
   Dim Count As Integer
   
   Set excel = GetObject(, "Excel.Application")
   Set excelSheet = excel.ActiveWorkbook.ActiveSheet
   excelSheet.Range(Cells(1, 1), Cells(45, ).Clear
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Bold = True
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Color = 1152
       Set acad = Nothing
   On Error Resume Next
   Set acad = GetObject(, "AutoCAD.Application")
   If Err <> 0 Then
       Set acad = CreateObject("AutoCAD.Application")
       acad.Visible = True
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If
   Set doc = acad.ActiveDocument
   Set mspace = doc.ModelSpace
   RowNum = 1
   Dim Header As Boolean
   Header = False
   For Each elem In mspace
       With elem
         If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
               If .HasAttributes Then
                   Array1 = .GetAttributes
                   For Count = LBound(Array1) To UBound(Array1)
                     If Header = False Then
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                     End If
                   Next Count
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                     excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
                   Header = True
               End If
         End If
       End With
   Next elem
   NumberOfAttributes = RowNum - 1
   If NumberOfAttributes > 0 Then
      ActiveWorkbook.ActiveSheet.Range("A1").Sort _
       key1:=ActiveWorkbook.ActiveSheet.Columns("A"), _
       Header:=xlGuess
   Else
       MsgBox "No attributes found in the current drawing."
   End If
   Set acad = Nothing
End Sub


Private Sub Auto_Close()
   Set excelSheet = Nothing
End Sub

BIGAL 发表于 2022-7-6 22:26:25

你需要在这里更深入一点。（EntityName，“AcDbBlockReference”，1）这返回yes它是一个块，然后你会添加另一个if，is=到我的块名中，在一个循环列表中为所需的块。
 
可能选择集直接生成为一组1块对象。
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
attribs = SS.Item(Cntr).GetAttributes

attribval1 = attribs(1).TextString

RICVBA 发表于 2022-7-6 22:34:50

 
至于excel编码，它实际上似乎适合列出单个块名事件，但您最好发布一个示例，说明您在块列表方面的实际需求。
如果我理解得很好，您希望在不同的列组中列出每个不同块名的所有引用。如果是这样，每个列表结构都严格地与每个块的标记数相连接，这些标记很可能彼此不同。因此，为要处理的每个块设置和使用不同的板材可能更有效。
让我知道。
 
与此同时，我认为你至少应该做以下改变
1)
    Set excelSheet = Excel.ActiveWorkbook.ActiveSheet
   With excelSheet
       .Range(.Cells(1, 1), .Cells(45, ).Clear
       .Range(.Cells(1, 1), .Cells(1, ).Font.Bold = True
       .Range(.Cells(1, 1), .Cells(1, ).Font.color = 1152
   End With

使代码运行
 
2)
                  For Count = LBound(Array1) To UBound(Array1)
                     excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count

 
和3）
    If NumberOfAttributes > 0 Then
      excelSheet.Range("A1").Sort _
       key1:=excelSheet.Columns("A"), _
       Header:=xlGuess
   Else

两者都只是为了在开始时正确设置变量
 
4)
                If .HasAttributes Then
                   Array1 = .GetAttributes
                   If Header = False Then
                     For Count = LBound(Array1) To UBound(Array1)
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                     Next Count
                     Header = True
                   End If
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                     excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
               End If
避免在处理标记字符串后进行无用的检查。
 
当然，上述所有内容都需要重写，以匹配Bigal建议，如果是这样，则每个blockname设置都需要一张表

tazzzz 发表于 2022-7-6 22:40:17

非常感谢您的回复。
我已经将你的建议应用到代码中，我觉得它比以前运行得更流畅了，但我仍然没有操作数据的能力。我听从了你的建议，创建了一个小的EXCEL数据示例：
1、数据提取将从BA列开始
2.BA和BB列对应于块1的属性
3.BC和BD列对应于块2的属性
4.Col Be对应于Block3的属性，依此类推。
有没有办法声明要提取哪些块/属性以及在哪里提取？
谢谢你的帮助和投入的时间。
EXCEL块列表。xlsx公司

RICVBA 发表于 2022-7-6 22:46:17

 
当然有！明天我会花一些时间，让你有一个代码，可以让你“深入挖掘”并达到你的目标。

RICVBA 发表于 2022-7-6 22:51:53

 
这是vba列表
 
选项ExplicitSub Extract（）如果此绘图为空，则MsgBox“请打开绘图文件，然后重新启动此宏。”如果“----------------------------------------------------”Excel设置Dim Excel As Application Dim MySheet As Excel，则退出子端。工作表Dim BlckNameRng为Excel。范围，标记为Excel。范围，myCell为Excel。Range Dim iniColStr As String Dim iniRow As Long，iniCol As Long“出错时处理excel应用程序继续下一步设置excel=GetObject（，“excel.application”），如果出错，则设置excel=CreateObject（“excel.application”）'用excel处理工作簿和工作表。Visible=True Set MySheet=。ActiveWorkbook。如果出现错误，则为ActiveSheet。工作簿。添加ActiveWorkbook。工作表。添加集MySheet=。ActiveWorkbook。ActiveSheet End If On Error GoTo 0 End With“handling columns where to start write data from iniColStr=“BA””

tazzzz 发表于 2022-7-6 23:04:08

你好RICVBA
你为这段代码所做的大量工作给我留下了深刻的印象，说实话，我说不出话来。我将此代码嵌入EXCEL电子表格中，但当我尝试运行宏时，我收到一条错误消息“变量未定义”。你认为windows 7-64位与此有关吗？
非常感谢。

RICVBA 发表于 2022-7-6 23:06:02

 
 
 
Tazzz，我从Autocad“透视”编写了vba代码。i、 e：您必须在Autocad（而不是Excel）中打开VBA IDE，插入模块并将代码粘贴到其代码窗口中，然后进行调试。别忘了确保您设置了正确的参考。
 
在此之后，可能会出现32-64位问题。但我希望这不会发生，因为我无法支持你。

tazzzz 发表于 2022-7-6 23:15:36

非常感谢您的澄清。如果64位有问题，我会想办法解决。

查看完整版本: 提取特定块