Changing attributes with VBA on multiple layouts
Changing attributes with VBA on multiple layouts
(OP)
At the end of a program where I make a lot of details in ModelSpace, I create a layout tab for each set of details. The new layout tabs are "Sheet1", "Sheet2", etc. I then insert a title block with attributes into each layout. I then need to go back and add the SheetNo attribute (ie."1 OF 10", "2 OF 10"...) to each title block.
I just want to select the blocks on each layout tab. As you can see, my filter doesn't do that. Also, the AddSheetNumbers part of the program puts the same sheet number data in all of the layouts title blocks. Can you help?
Here is the code.
intCodes(0) = -4: varCodeValues(0) = "<AND"
intCodes(1) = 0: varCodeValues(1) = "BLOCK"
intCodes(2) = -4: varCodeValues(2) = "<OR"
intCodes(3) = 8: varCodeValues(3) = "TEXT"
intCodes(4) = -4: varCodeValues(4) = "OR>"
intCodes(5) = 67: varCodeValues(5) = "0"
intCodes(6) = -4: varCodeValues(6) = "AND>"
Public Sub AddSheetNumbers()
For Each objLayout In ThisDrawing.Layouts
ThisDrawing.ActiveLayout = objLayout
If Left$(objLayout.Name, 5) = "Sheet" Then
Newlayout = objLayout.Name
I = Len(Newlayout)
On Error Resume Next
ThisDrawing.SelectionSets("TEMP").Delete
Set objSS = ThisDrawing.SelectionSets.Add("TEMP")
objSS.Select 5, Pt2, Pt1, intCodes, varCodeValues
For Each objBlockRef In objSS
If objBlockRef.Name = "TitleBlock" Then
For Each varAttribute In objBlockRef.GetAttributes
Select Case varAttribute.TagString
Case "SheetNo":
varAttribute.TextString = Right$(Newlayout, I - 5) & " OF " & Int((DetNo + 2) / 2)
End Select
Next varAttribute
End If
Next objBlockRef
End If
Next objLayout
End Sub
I just want to select the blocks on each layout tab. As you can see, my filter doesn't do that. Also, the AddSheetNumbers part of the program puts the same sheet number data in all of the layouts title blocks. Can you help?
Here is the code.
intCodes(0) = -4: varCodeValues(0) = "<AND"
intCodes(1) = 0: varCodeValues(1) = "BLOCK"
intCodes(2) = -4: varCodeValues(2) = "<OR"
intCodes(3) = 8: varCodeValues(3) = "TEXT"
intCodes(4) = -4: varCodeValues(4) = "OR>"
intCodes(5) = 67: varCodeValues(5) = "0"
intCodes(6) = -4: varCodeValues(6) = "AND>"
Public Sub AddSheetNumbers()
For Each objLayout In ThisDrawing.Layouts
ThisDrawing.ActiveLayout = objLayout
If Left$(objLayout.Name, 5) = "Sheet" Then
Newlayout = objLayout.Name
I = Len(Newlayout)
On Error Resume Next
ThisDrawing.SelectionSets("TEMP").Delete
Set objSS = ThisDrawing.SelectionSets.Add("TEMP")
objSS.Select 5, Pt2, Pt1, intCodes, varCodeValues
For Each objBlockRef In objSS
If objBlockRef.Name = "TitleBlock" Then
For Each varAttribute In objBlockRef.GetAttributes
Select Case varAttribute.TagString
Case "SheetNo":
varAttribute.TextString = Right$(Newlayout, I - 5) & " OF " & Int((DetNo + 2) / 2)
End Select
Next varAttribute
End If
Next objBlockRef
End If
Next objLayout
End Sub





RE: Changing attributes with VBA on multiple layouts
Public Function GetObjectLayoutName(ByRef acObj As AcadEntity) As String
'------------------------------------------------------------------------------
'GetobjectLayoutName:
'Arguments: Autocad object
'Returns: string eg "Model" or "Layout1" or "Layout2" etc...
'------------------------------------------------------------------------------
Dim acLayout As AcadLayout
''''''''''''''''''''
For Each acLayout In ThisDrawing.Layouts
If acObj.OwnerID = acLayout.Block.ObjectID Then
Set GetLayoutName = acLayout.Name
Exit Function
End If
Next
End Function
And from there I set the attributes in the title. I hope this is a help.
http://mechcad-insider.blogspot.com/
"The fear of the Lord is the beginning of wisdom"