从模型空间获取所有属性块乐筑天下

Eloquintet 发表于 2007-4-24 09:05:40

从模型空间获取所有属性块

嘿，伙计们，我有一个程序，允许用户跨多个文件更新所有布局中的属性，但现在我需要跨多个文档更新模型空间中的属性。我试图修改它，但无法使其工作。有人能帮我做一下基本上相反的事情吗'Returns all the attributed inserted blocks in a drawings layouts
Private Function GetBlocks(ByVal theDoc As AcadDocument, _
                        ByRef BlockStore As Scripting.Dictionary)
'Set dictionary's comparison mode to work with text
BlockStore.CompareMode = TextCompare

Dim aEntity As AcadEntity 'Stores each entity in turn
Dim aLayout As AcadLayout 'Stores each layout in turn
Dim aBlkRef As AcadBlockReference 'Stores a block reference
For Each aLayout In theDoc.Layouts 'Loop thru all the layouts
'The below condition is for performance, it excludes ModelSpace
If Not (aLayout.ModelType) Then
   For Each aEntity In aLayout.Block 'Loop thru all entities
   'If the current entity is a block insertion
   If TypeOf aEntity Is AcadBlockReference Then
      Set aBlkRef = aEntity 'Cast the entity into a block ref
      'If the block insertion has attributes
      If aBlkRef.HasAttributes Then
         'Use a procedure to add block to dictionary
         'Need procedure for isolated error handling
         AddBlock BlockStore, aBlkRef.Name, aBlkRef.GetAttributes
      End If
   End If
   Next aEntity
End If
Next aLayout
End Function

Eloquintet 发表于 2007-4-24 09:54:50

顺便说一句，这是我的尝试。我得到一个错误，它突出显示了AcadModel和开头？本人&#039；我不确定我的语法
'Returns all the attributed inserted blocks in Modelspace
Private Function GetBlocks(ByVal theDoc As AcadDocument, _
                        ByRef BlockStore As Scripting.Dictionary)
'Set dictionary's comparison mode to work with text
BlockStore.CompareMode = TextCompare

Dim aEntity As AcadEntity 'Stores each entity in turn
Dim aModel As AcadModel 'Stores each Modelspace in turn
Dim aBlkRef As AcadBlockReference 'Stores a block reference
For Each aModel In theDoc.Model 'Loop thru all the modelspaces
'The below condition is for performance, it excludes ModelSpace
If Not (aModel.LayoutType) Then
   For Each aEntity In aModel.Block 'Loop thru all entities
   'If the current entity is a block insertion
   If TypeOf aEntity Is AcadBlockReference Then
      Set aBlkRef = aEntity 'Cast the entity into a block ref
      'If the block insertion has attributes
      If aBlkRef.HasAttributes Then
         'Use a procedure to add block to dictionary
         'Need procedure for isolated error handling
         AddBlock BlockStore, aBlkRef.Name, aBlkRef.GetAttributes
      End If
   End If
   Next aEntity
End If
Next aModel
End Function

Bryco 发表于 2007-4-24 10:14:02

选择集更快Sub GetBlocks(ByVal theDoc As AcadDocument, _
ByRef BlockStore As Scripting.Dictionary)
Dim SS As AcadSelectionSet
Dim FType(1) As Integer
Dim FData(1) As Variant
Dim oBref As AcadBlockReference

On Error Resume Next
ThisDrawing.SelectionSets("BRefs").Delete
On Error GoTo 0
FType(0) = 0: FData(0) = "Insert"
FType(1) = 67: FData(1) = 0

Set SS = ThisDrawing.SelectionSets.Add("BRefs")
SS.Select 5, , , FType, FData
Debug.Print SS.count
For Each oBref In SS
If oBref.HasAttributes Then
AddBlock BlockStore, oBref.Name, oBref.GetAttributes
End If
Next oBref

SS.Delete
End Sub

Bryco 发表于 2007-4-24 10:19:51

Dim aModel，因为AcadModelSpace是一个块，其中只有一个，因此没有循环，请改用Set AMODLE=ThisDrawing。模型空间或设置aModel=doc。模型空间

Eloquintet 发表于 2007-4-24 10:59:04

Dan，
看看这个.dvb文件，以获取和替换属性值的选择集示例

Eloquintet 发表于 2007-4-24 11:33:00

我一直在玩这个，现在仍然可以#039；我不明白。当我运行它时，我得到一个错误，并突出显示Next aEntity。我真的需要这个工作，但不幸的是唐&#039；我没有很多时间玩它
'Returns all the attributed inserted blocks in Modelspace
Private Function GetBlocks(ByVal theDoc As AcadDocument, _
                        ByRef BlockStore As Scripting.Dictionary)
'Set dictionary's comparison mode to work with text
BlockStore.CompareMode = TextCompare

Dim aEntity As AcadEntity 'Stores each entity in turn
Dim aModel As AcadModelSpace 'Stores each layout in turn
Set aModel = ThisDrawing.ModelSpace
Dim aBlkRef As AcadBlockReference 'Stores a block reference
      'If the current entity is a block insertion
   If TypeOf aEntity Is AcadBlockReference Then
      Set aBlkRef = aEntity 'Cast the entity into a block ref
      'If the block insertion has attributes
      If aBlkRef.HasAttributes Then
         'Use a procedure to add block to dictionary
         'Need procedure for isolated error handling
         AddBlock BlockStore, aBlkRef.Name, aBlkRef.GetAttributes
      End If
   End If
   Next aEntity
End If
Next aModel
End Function

Eloquintet 发表于 2007-4-24 12:15:59

本人&#039；我不确定你是如何存储属性的（也许一个数组可以工作？）。只有一个属性吗
否则，您需要一种匹配属性的方法。名称，然后更改属性。文本并对其进行迭代。

Eloquintet 发表于 2007-4-24 13:09:02

亚利桑那州，我相信它们被存储为一个数组。我张贴了完整的代码，为布局工作（这是我应该做的第一位）。基本上，我有大约60个楼层平面图，上面有详图索引。细节在最初的第9页和第10页，但现在我必须添加所有这些计划。所以我需要打开所有的图纸，检查所有的9到66，所有的10到67。这有意义吗

Option Explicit
'Stores block names & attributes for 1st inserted block of each
Public AllBlocks As Scripting.Dictionary
'Stores attributes for selected block
Public AllAttribs As Variant
'Macro for user interface
Public Sub Updateattribute()
Dim myFiles As Variant 'Stores filenames selected in array
myFiles = GetFiles 'Store filenames selected by user in array

'AllBlocks is a public variable
Set AllBlocks = New Scripting.Dictionary 'Initialize storage
BlockDialog.BlockPicked = "" 'Initialize check variable
Set AttribDialog.AttribPicked = Nothing 'Initialize check variable
TextDialog.DoUpdate = False 'Initialize check variable

'If files are selected
If IsArray(myFiles) Then
Dim myDoc As AcadDocument 'Need a variable for a drawing
'Get the first drawing selected by user
Set myDoc = AcadApplication.Documents.Open(myFiles(0))
GetBlocks myDoc, AllBlocks 'Get all attributed blocks in dwg
End If

'There may be no attributed blocks, so need to test
If AllBlocks.Count > 0 Then BlockDialog.Show 'Show list of blocks

'If a block was selected
If BlockDialog.BlockPicked"" Then
'Store attributes from selected block in public variable
AllAttribs = AllBlocks.Item(BlockDialog.BlockPicked)
AttribDialog.Show 'Show list of attributes
End If

'If an attribute was selected
If Not (AttribDialog.AttribPicked Is Nothing) Then
TextDialog.Show 'Display dialog to get new string
End If

'If OK was hit in the TextDialog
If TextDialog.DoUpdate Then
'Change all the drawings the user selected
ProcessDrawings myFiles, _
               BlockDialog.BlockPicked, _
               AttribDialog.AttribPicked.TagString, _
               TextDialog.NewText

'Inform the user things are done
MsgBox "Process is complete.", vbOKOnly, "ABC's of VBA"
Else
myDoc.Close False 'Close drawing left open during cancel
End If
End Sub
'Open all given drawings and change selected attribute
Private Sub ProcessDrawings(ByVal Dwgs As Variant, _
                        ByVal BlockName As String, _
                        ByVal TagName As String, _
                        ByVal NewText As String)
'The following creates a selection set filter
Dim fType(0 To 1) As Integer 'Stores DXF-style codes
Dim fData(0 To 1) As Variant 'Stores filters
fType(0) = 0: fData(0) = "INSERT" 'Filter for block insertions
fType(1) = 2: fData(1) = BlockName 'Filter for specific block

Dim openFilename As String 'Stores name of open drawing
Dim myDwg As AcadDocument 'Stores each drawing in turn
Dim mySS As AcadSelectionSet 'Stores selection set
Dim myAtts As Variant 'Stores attributes for each insertion
Dim i As Long, j As Long 'Declare two counters

For i = 0 To UBound(Dwgs) 'Loop thru all drawings
openFilename = GetOpenFilename(Dwgs(i)) 'Checks if file is open
'If the drawing is open, just refer to open drawing
If openFilename"" Then
   Set myDwg = AcadApplication.Documents.Item(openFilename)
Else 'Open the drawing
   Set myDwg = AcadApplication.Documents.Open(Dwgs(i))
End If

Set mySS = GetSS(myDwg) 'Get a selection set

'Populate the selection set with specified block insertions
mySS.Select Mode:=acSelectionSetAll, _
            FilterType:=fType, _
            FilterData:=fData

For j = 0 To mySS.Count - 1 'Loop thru all selected blocks
   ChangeAttrib mySS.Item(j), TagName, NewText 'Change attribute
Next j

mySS.Delete 'Always delete a selection set when done with it
myDwg.Close Not myDwg.ReadOnly 'Close drawing, saving changes
Next i
End Sub
'Checks to see if the given fully-qualified filename is open
'Returns the filename without path if it is open
Private Function GetOpenFilename(fqnName As Variant) As String
Dim i As Long 'Declare a counter
'Loop thru all open drawings
For i = 0 To AcadApplication.Documents.Count - 1
'Use the document given below for its properties
With AcadApplication.Documents.Item(i)
   'Compare two strings, if they match (equal 0) then return Name
   If StrComp(.FullName, fqnName, vbTextCompare) = 0 Then
   GetOpenFilename = .Name
   Exit For 'Since a match was found, exit the loop
   End If
End With
Next i
End Function
'Returns a named selection set
Private Function GetSS(ByRef theDoc As AcadDocument, _
                  Optional ByVal Name As String = "mySS") _
                  As AcadSelectionSet
'Enable error handling, but just skip the error
On Error Resume Next
'Attempt to get the named selection set
Set GetSS = theDoc.SelectionSets.Item(Name)
GetSS.Clear 'Clear the selection set of any items
'If this error occurred, the selection set didn't exist, create it
If Err.Number = 91 Then Set GetSS = theDoc.SelectionSets.Add(Name)
End Function
'Change the given attribute in the given block reference
Private Sub ChangeAttrib(ByVal theBlock As AcadBlockReference, _
                     ByVal TagName As String, _
                     ByVal NewText As String)
Dim myAtts As Variant 'GetAttributes returns an array
myAtts = theBlock.GetAttributes 'Get the attributes

Dim i As Long 'Declare a counter
For i = 0 To UBound(myAtts) 'Loop thru all attributes
With myAtts(i) 'For each attribute
   'If the current attribute is the correct one
   If .TagString = TagName Then
   .TextString = NewText 'change the attributes value
   Exit For 'Exit the loop, we are done
   End If
End With
Next i
End Sub
'Returns all the attributed inserted blocks in a drawings layouts
Private Function GetBlocks(ByVal theDoc As AcadDocument, _
                        ByRef BlockStore As Scripting.Dictionary)
'Set dictionary's comparison mode to work with text
BlockStore.CompareMode = TextCompare

Dim aEntity As AcadEntity 'Stores each entity in turn
Dim aLayout As AcadLayout 'Stores each layout in turn
Dim aBlkRef As AcadBlockReference 'Stores a block reference
For Each aLayout In theDoc.Layouts 'Loop thru all the layouts
'The below condition is for performance, it excludes ModelSpace
If Not (aLayout.ModelType) Then
   For Each aEntity In aLayout.Block 'Loop thru all entities
   'If the current entity is a block insertion
   If TypeOf aEntity Is AcadBlockReference Then
      Set aBlkRef = aEntity 'Cast the entity into a block ref
      'If the block insertion has attributes
      If aBlkRef.HasAttributes Then
         'Use a procedure to add block to dictionary
         'Need procedure for isolated error handling
         AddBlock BlockStore, aBlkRef.Name, aBlkRef.GetAttributes
      End If
   End If
   Next aEntity
End If
Next aLayout
End Function
'Adds a block name and its attributes to a dictionary
Private Sub AddBlock(ByRef BlockStore As Scripting.Dictionary, _
                  ByVal Name As String, _
                  ByVal Attribs As Variant)
'Enable error handling, but just skip the error
On Error Resume Next
'Attempt to add block name and its attributes to the dictionary
'If the block name already exists in the dictionary,
'an error occurs. So this procedure just skips the duplicate.
BlockStore.Add Name, Attribs
End Sub
'Display an open dialog, adds selected files to an array
Private Function GetFiles() As Variant
'Stores the object created by the CommonDialog class
Dim myOpen As CommonDialogProject.CommonDialog
Set myOpen = CommonDialogProject.Init 'Create the object

myOpen.DialogTitle = "Select drawings" 'Change the title
myOpen.Filter = "AutoCAD Drawing files (*.dwg)|*.dwg|" & _
                     "AutoCAD Drawing template files (*.dwt)|*.dwt"
myOpen.DefaultExt = "dwg"
'Set flags to limit behavior of the dialog box
myOpen.Flags = OFN_ALLOWMULTISELECT + _
            OFN_EXPLORER + _
            OFN_FILEMUSTEXIST + _
            OFN_HIDEREADONLY + _
            OFN_PATHMUSTEXIST
myOpen.InitDir = FindPath("Drawings")
myOpen.MaxFileSize = 2048 'Increase buffer of filenames

Dim success As Long 'Stores the return value from CommonDialog
success = myOpen.ShowOpen 'Display the open dialog box
'If the dialog was not cancelled get array of filenames
If success > 0 Then GetFiles = myOpen.ParseFileNames
End Function
Private Function FindPath(ByVal path As String) As String
Dim X As Integer
Dim rVal As String
On Error Resume Next
For X = 67 To 69
rVal = Dir(Chr(X) & ":\" & path & "\*.*")
If rVal"" Then
FindPath = Chr(X) & ":\" & path
X = 70
Else
FindPath = "C:\"
End If
Next X
End Function

Bryco 发表于 2007-4-24 15:05:43

嗯，我在这里的处境很糟糕。我做了建筑的一个角落，然后将这些街区镜像到另一个角落。当我这样做的时候，当然是镜像属性。我使用了一个lisp，我有它交换了这两个，所以细节编号再次在顶部和底部的表。我没有注意到的是，它交换了值，但没有交换标记。现在我需要增加图纸，但在镜像块上，细节值与图纸标记相关联。这有什么意义吗。基本上是I&#039；m拧紧。

Eloquintet 发表于 2007-4-24 15:08:26

有没有办法交换属性标记？

页: [1] 2

乐筑天下's Archiver

从模型空间获取所有属性块