Author Topic: Getting all attributed blocks from model space  (Read 5307 times)

0 Members and 1 Guest are viewing this topic.

ELOQUINTET

  • Guest
Getting all attributed blocks from model space
« on: April 24, 2007, 09:05:40 AM »
Hey guys,

I have a program which allows the user to update an attribute in all layouts across multiple files but now I have a need to update an attribute in model space across multiple files. I was trying to modify it but cannot get it to work. Can somebody help me out with doing the reverse of this basically


Code: [Select]
'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

  • Guest
Re: Getting all attributed blocks from model space
« Reply #1 on: April 24, 2007, 09:54:50 AM »
this is my attempt by the way. I get an error and it highlights AcadModel and the beginning? I'm not sure about my syntax.

Code: [Select]
'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

  • Water Moccasin
  • Posts: 1882
Re: Getting all attributed blocks from model space
« Reply #2 on: April 24, 2007, 10:14:02 AM »
Selectionsets are faster,
Code: [Select]
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

  • Water Moccasin
  • Posts: 1882
Re: Getting all attributed blocks from model space
« Reply #3 on: April 24, 2007, 10:19:51 AM »
Dim aModel As AcadModelSpace
modelspace is a block and there is only one of them so there is no loop, instead use
Set aModel = ThisDrawing.ModelSpace
or Set aModel = theDoc.ModelSpace

Arizona

  • Guest
Re: Getting all attributed blocks from model space
« Reply #4 on: April 24, 2007, 10:59:04 AM »
Dan,

Look at this .dvb file for an example of selection sets, getting and replacing the values of attributes.

ELOQUINTET

  • Guest
Re: Getting all attributed blocks from model space
« Reply #5 on: April 24, 2007, 11:33:00 AM »
I have been playing with this and still can't get it. When i run it i get an error and Next aEntity is highlighted. I really need this to work but unfortunately don't have alot of time to play with it.

Code: [Select]
'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

Arizona

  • Guest
Re: Getting all attributed blocks from model space
« Reply #6 on: April 24, 2007, 12:15:59 PM »
I'm not sure how you are storing your attributes (perhaps an array would work?). Is there only one attribute?
Otherwise you would need a method of matching the attribute.name then altering the attribute.text and iterating through them.

ELOQUINTET

  • Guest
Re: Getting all attributed blocks from model space
« Reply #7 on: April 24, 2007, 01:09:02 PM »
arizona,

I believe they are being stored as an array. I am posting the complete code that works for layouts (which is what i should have done in the first place). Basically I have about 60 floor plans with detail callouts on them. The details were on sheets 9 and 10 of original set but now i have to add all of these plans. So i need to open all the drawings up and checnge all of the 9s to say 66 and all the 10s to 67. does that make sense?

 
Code: [Select]
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

ELOQUINTET

  • Guest
Re: Getting all attributed blocks from model space
« Reply #8 on: April 24, 2007, 03:05:43 PM »
hmmm i am in a very bad way here. i did one corner of the building then mirrored the blocks to the other corner. when i did so of course the attributes mirrored. i used a lisp i have which swaps the two so the detail number is again on top and the sheet on bottom. What I failed to notice is that it swapped the value but not the tag. Now i need to increment the sheets but on the mirrored blocks the detail value is associated with the sheet tag. is any of this making sense. Basically I'm screwed.

ELOQUINTET

  • Guest
Re: Getting all attributed blocks from model space
« Reply #9 on: April 24, 2007, 03:08:26 PM »
is there a way i can swap attribute tags?

Arizona

  • Guest
Re: Getting all attributed blocks from model space
« Reply #10 on: April 24, 2007, 03:22:09 PM »
Yes, at the point that you have the tag you can get it's insertion points.

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Getting all attributed blocks from model space
« Reply #11 on: April 25, 2007, 12:04:35 AM »
Not sure what you want but if you comment out If Not (aLayout.ModelType) Then by adding a ' in front of it and comment out the corresponding end if you will get every block ref,
If you only want the blocks in modelspace use what I gave you or replace "If Not (aLayout.ModelType) Then" with
If aLayout.ModelType Then

Code: [Select]
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

ELOQUINTET

  • Guest
Re: Getting all attributed blocks from model space
« Reply #12 on: April 25, 2007, 08:35:51 AM »
well bryco i have a bit of another problem now if you read the posts above. basically i started on one corner of the building then mirrored my blocks to the other side. this mirroed the attributes so i used a routine that swapped the values the only problem is it didn't also swap the tags. now i need to swap the tags for for this method to work or maybe instead of looking for a tag it could look for numerical values inside the block as all the sheet designations are numerical. any advice?

Arizona

  • Guest
Re: Getting all attributed blocks from model space
« Reply #13 on: April 25, 2007, 06:38:59 PM »
Take a look at the file above, where I am swapping some of the attribute values (and string contents) that might help.

P.S. Bryco knows way more than I do about this :-)

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Getting all attributed blocks from model space
« Reply #14 on: April 25, 2007, 11:37:52 PM »
Use some lisp to reinsert the bad inserts, test for isnumeric to figure out which tag is which. The way I see it you need to spend a little time learning vba as you have so much programming done in this. It sure looks a lot easier than lisp. But the program you have is too complicated to apply a quick fix without knowing the whole program.