Title Block Copy - Equivalent to a double-click on the Drawing Resource

[shastu]

This should be so simple but I can't get it accomplished.  I have the code that copies the Drawing Resources in and then all I need is to add it to the active sheet.  I have looked online and tried several different things but nothing works.  The Title Block has prompted entries and is called ANSI A.  Here is the code that I have.

Sub TitleBlockCopy()

    Dim oSourceDocument As DrawingDocument
    Set oSourceDocument = ThisApplication.ActiveDocument
  
    ' Open the template drawing to copy the title block from.
    Dim oNewDocument As DrawingDocument
    ' if you put false here at the end it will not open visible, so you won't need to close it
    Set oNewDocument = ThisApplication.Documents.Open("Q:\Inventor\Templates_v2014\Templates\part.idw", False)
  
    ' Get the new title block definition.
    Dim oNewTitleBlockDef As TitleBlockDefinition
    'make sure that in your template.idw the needed titleblock is active
    Set oNewTitleBlockDef = oNewDocument.ActiveSheet.TitleBlock.Definition
  
    ' Set the new title block definition.
    Dim oSourceTitleBlockDef As TitleBlockDefinition
    Set oSourceTitleBlockDef = oNewTitleBlockDef.CopyTo(oSourceDocument)
  
    ' Iterate through the sheets.
    Dim oSheet As Sheet
    For Each oSheet In oSourceDocument.Sheets

oSheet.Activate
Dim oTitleBlock As TitleBlock

'THE BELOW LINE IS THE PART THAT I CAN'T GET TO WORK.
Set oTitleBlock = oSheet.AddTitleBlock("ANSI A")
       
     Next
End Sub

[demuff]

Is the AddTitleBlock method throwing an error or does it just do nothing? Have you tried passing in the actual title block object rather than the string name?

[MechMachineMan · Accepted solution]

I found your problem.

@shastu wrote:

The Title Block has prompted entries

For a TB with 1 prompted entry:

Dim sPromptStrings(0) As String
sPromptStrings(0) = ""

 OR For 2:

Dim sPromptStrings(0 To 1) As String
sPromptStrings(0) = ""
sPromptStrings(1) = ""

Extrapolate this if it has more...

Also, look here for the API Documentation on add titleblock....

http://help.autodesk.com/view/INVNTOR/2018/ENU/?guid=GUID-F9EB14F1-F2D8-41CC-8B61-07B9A5478267

ex://

Set oTitleBlock = oSheet.AddTitleBlock("ANSI A",, sPromptStrings)

[chandra.shekar.g]

Hi Shawn,

Yes, it is very simple.

Make sure that before adding title block, existing title block should be deleted.

Sub TitleBlockCopy()

    Dim oSourceDocument As DrawingDocument
    Set oSourceDocument = ThisApplication.ActiveDocument
   
    ' Open the template drawing to copy the title block from.
    Dim oNewDocument As DrawingDocument
    ' if you put false here at the end it will not open visible, so you won't need to close it
    Set oNewDocument = ThisApplication.Documents.Open("Q:\Inventor\Templates_v2014\Templates\part.idw", False)
   
    ' Get the new title block definition.
    Dim oNewTitleBlockDef As TitleBlockDefinition
    'make sure that in your template.idw the needed titleblock is active
    Set oNewTitleBlockDef = oNewDocument.ActiveSheet.TitleBlock.Definition
   
    ' Set the new title block definition.
    Dim oSourceTitleBlockDef As TitleBlockDefinition
    Set oSourceTitleBlockDef = oNewTitleBlockDef.CopyTo(oSourceDocument)
   
    ' Iterate through the sheets.
    Dim oSheet As Sheet
    For Each oSheet In oSourceDocument.Sheets
        oSheet.Activate
	
	Call oSheet.TitleBlock.Delete

        Dim oTitleBlock As TitleBlock
        Set oTitleBlock = oSheet.AddTitleBlock("ANSI A")
        
    Next
End Sub

One more point, title block "ANSI A" should be available in Drawing resources of activedocument.

Please feel free to contact if there is any doubt.

If solve your problem, click on "Accept as solution" / give a "Kudo".

Thanks and regards,

[Anonymous]

Hi

i have copied your code and pasted in VBA editor... the code works fine upto deleting Title block and showing an error exactly at below mentioned line...

Set oTitleBlock = oSheet.AddTitleBlock("ANSI A")

Please help...

Thanks in Advance.

[shastu]

Well,  As mentioned above, my problem was that I had prompted entries.  I assume that is your problem as well.  So I wanted to capture the information that was already in the prompted entries and retain that information so that once I brought in the updated title block that I would not lose that information.  I also wanted to make sure that I went through all pages and updated the title block on each and every page.  Here is the code I came up with but you will have to modify it to match your prompted entry titles.

Sub Update_TitleBlock(OrigFileLoc, oDocIDW, DerivedPartOriginalFile, SavedName)

 Dim oDocIDWStyles As Inventor.DrawingStylesManager
 Set oDocIDWStyles = oDocIDW.StylesManager

 Dim i As Integer
On Error Resume Next

 'Update Sytles to Global
 For i = 1 To oDocIDWStyles.Styles.Count
' Debug.Print "Styles - " + oDocIDWStyles.Styles.Item(i).Name
 If oDocIDWStyles.Styles.Item(i).UpToDate = False Then
 'MsgBox oDocIDWStyles.Styles.Item(i).Name
 If oDocIDWStyles.Styles.Item(i).Name = "ANSI" Then
oDocIDWStyles.Styles.Item(i).UpdateFromGlobal
 End If
 If oDocIDWStyles.Styles.Item(i).Name = "Bradbury-H" Then
oDocIDWStyles.Styles.Item(i).UpdateFromGlobal
 End If
 End If
 
 Next
    If (oDocIDW.DocumentType <> kDrawingDocumentObject) Then Exit Sub
   
    Dim oTemplate As DrawingDocument
    Dim oSourceTitleBlockDef As TitleBlockDefinition
    Dim oNewTitleBlockDef As TitleBlockDefinition
    Dim oSheet As Sheet
    Dim titlename As String
    Dim oPane As BrowserPane
    Dim oDocumentNode As BrowserNode
    Dim oDrawingResourceNode As BrowserNode

    Set oSheet = oDocIDW.ActiveSheet
   
    Set oTitleBlock = oSheet.TitleBlock

        If oTitleBlock.Definition.Sketch.TextBoxes Is Nothing Then Exit Sub

            Set oTextBoxes = oTitleBlock.Definition.Sketch.TextBoxes

            For Each oTextBox In oTextBoxes
            'MsgBox oTextBox.Text
               
                If oTextBox.Text = "MJS" Then
                   'MsgBox ("This is a Part")
                   fname = "Bradbury Template.idw"
               
                   GoTo DoneWithThisFor
                           
                ElseIf oTextBox.Text = "Enter Raw Stock Noun" Then
                   'MsgBox ("This is a Part")
                   fname = "PART.idw"
               
                   GoTo DoneWithThisFor
                    'MsgBox SecondDescr
                ElseIf oTextBox.Text = "CROSS-SECTION" Then
                   'MsgBox ("This is a Cross Section")
                   fname = "Cross Section.idw"
                   GoTo DoneWithThisFor
                ElseIf oTextBox.Text = "MACHINE TYPE" Then
                    'MsgBox ("This is a LUBE TEMPLATE")
                   fname = "LUBETEMPLATE.idw"
                   GoTo DoneWithThisFor
                ElseIf oTextBox.Text = "MISCELLANEOUS MATERIALS" Then
                    'MsgBox ("This is a MISC_INSTALL")
                   fname = "MISC_INSTALL.idw"
                   GoTo DoneWithThisFor
                 ElseIf oTextBox.Text = "INSTALLATION DRAWING" Then
                    'MsgBox ("This is a INSTALLATION DRAWING")
                   fname = "RT Installation.idw"
                   GoTo DoneWithThisFor
                   Else
                   fname = "ASSY.idw"
                  
        End If
            Next
'End of Extraction
DoneWithThisFor:

    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    Dim d As Integer
    Dim e As Integer
    Dim f As Integer

    Dim Count As Integer
    Dim TitleBlockArray() As Variant
    Dim oBorderDefinition As BorderDefinition
    Dim oTitleBlockDefinition As TitleBlockDefinition
    Dim oNewDocument As DrawingDocument

If fname = "Cross Section.idw" Then

    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(oDocIDW, True)
    oTemplate.Close
   
    Set oSheet = oDocIDW.ActiveSheet
    Count = oDocIDW.Sheets.Count * 3
    a = 0
    b = 1
    c = 2
    d = 3
    e = 4
    f = 5
   

   ReDim TitleBlockArray(Count) As Variant
    
     For Each oSheet In oDocIDW.Sheets

        If oSheet.TitleBlock Is Nothing Then Exit Sub

        Set oTitleBlock = oSheet.TitleBlock

        If oTitleBlock.Definition.Sketch.TextBoxes Is Nothing Then Exit Sub

            Set oTextBoxes = oTitleBlock.Definition.Sketch.TextBoxes
  

            For Each oTextBox In oTextBoxes
                If oTextBox.Text = "Enter Second Line Description" Then
                    SecondDescr = oTitleBlock.GetResultText(oTextBox)
                ElseIf oTextBox.Text = "PART No." Then
                    PartNo = oTitleBlock.GetResultText(oTextBox)
                ElseIf oTextBox.Text = "SCALE" Then
                    SCALEtxt = oTitleBlock.GetResultText(oTextBox)
                End If
               Next
Array4text:
   TitleBlockArray(a) = SecondDescr
   TitleBlockArray(b) = PartNo
   TitleBlockArray(c) = SCALEtxt

a = a + 3
b = b + 3
c = c + 3

 Count = Count - 1
   Next
   
'Delete the Titleblock from all sheets
For oSheetNumber = 1 To oDocIDW.Sheets.Count
            Set oSheet = oDocIDW.Sheets(oSheetNumber)
            oSheet.TitleBlock.Delete
Next
 
 For Each oTitleBlockDefinition In oDocIDW.TitleBlockDefinitions
    If oTitleBlockDefinition.Name = "ANSI A" Then
        oTitleBlockDefinition.Delete
    End If
 Next
 
  
    ' Open the template drawing to copy the title block from.
    ' if you put false here at the end it will not open visible
    Set oNewDocument = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)

  
    ' Get the new title block definition.
    Set oNewTitleBlockDef = oNewDocument.ActiveSheet.TitleBlock.Definition
  
    ' Set the new title block definition.
    Set oSourceTitleBlockDef = oNewTitleBlockDef.CopyTo(oDocIDW)
    oNewDocument.Close
   
   
    Count = oDocIDW.Sheets.Count * 3
    Count = Count - 1
    Dim FinalCount As Integer
    FinalCount = Count
    Count = 0
    ' Iterate through the sheets.
    For Each oSheet In oDocIDW.Sheets

oSheet.Activate

a = Count
b = Count + 1
c = Count + 2
    Set oTitleBlock = oSheet.TitleBlock
               
SavedName = Right(SavedName, Len(SavedName) - 3)
SavedName = "BCO-" & SavedName
Dim sPromptString(0 To 6) As String
sPromptString(0) = SavedName
sPromptString(1) = TitleBlockArray(a)
sPromptString(2) = ""
sPromptString(3) = TitleBlockArray(c)
sPromptString(4) = ""
sPromptString(5) = ""
sPromptString(6) = ""
sPromptString(7) = ""

'Puts Titleblock back in to sheet
Set oTitleBlock = oSheet.AddTitleBlock("ANSI A", , sPromptString)
Count = Count + 3
Next
Else
    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(oDocIDW, True)
    oTemplate.Close
   
'    Dim a As Integer
'    Dim b As Integer
'    Dim c As Integer
'
'    Dim Count As Integer
   
    Set oSheet = oDocIDW.ActiveSheet
    Count = oDocIDW.Sheets.Count * 3
    a = 0
    b = 1
    c = 2

'   Dim TitleBlockArray() As Variant
   ReDim TitleBlockArray(Count) As Variant
    
     For Each oSheet In oDocIDW.Sheets

        If oSheet.TitleBlock Is Nothing Then Exit Sub

        Set oTitleBlock = oSheet.TitleBlock

        If oTitleBlock.Definition.Sketch.TextBoxes Is Nothing Then Exit Sub

            Set oTextBoxes = oTitleBlock.Definition.Sketch.TextBoxes
  

            For Each oTextBox In oTextBoxes
                If oTextBox.Text = "Enter Second Line Description" Then
                    SecondDescr = oTitleBlock.GetResultText(oTextBox)
                ElseIf oTextBox.Text = "Enter Raw Stock Noun" Then
                    Noun = oTitleBlock.GetResultText(oTextBox)
                ElseIf oTextBox.Text = "Enter Raw Stock Description" Then
                    RawStock1Desc = oTitleBlock.GetResultText(oTextBox)
                End If
               Next
'Array4text:
   TitleBlockArray(a) = SecondDescr
   TitleBlockArray(b) = Noun
   TitleBlockArray(c) = RawStock1Desc

a = a + 3
b = b + 3
c = c + 3

 Count = Count - 1
   Next
   
'Delete the Titleblock from all sheets
For oSheetNumber = 1 To oDocIDW.Sheets.Count
            Set oSheet = oDocIDW.Sheets(oSheetNumber)
            oSheet.TitleBlock.Delete
Next
 
' Dim oBorderDefinition As BorderDefinition
' Dim oTitleBlockDefinition As TitleBlockDefinition

 For Each oTitleBlockDefinition In oDocIDW.TitleBlockDefinitions
    If oTitleBlockDefinition.Name = "ANSI A" Then
        oTitleBlockDefinition.Delete
    End If
 Next
 
  
    ' Open the template drawing to copy the title block from.
'    Dim oNewDocument As DrawingDocument
    ' if you put false here at the end it will not open visible
    Set oNewDocument = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)

  
    ' Get the new title block definition.
    Set oNewTitleBlockDef = oNewDocument.ActiveSheet.TitleBlock.Definition
  
    ' Set the new title block definition.
    Set oSourceTitleBlockDef = oNewTitleBlockDef.CopyTo(oDocIDW)
    oNewDocument.Close
   
   
    Count = oDocIDW.Sheets.Count * 3
    Count = Count - 1
'    Dim FinalCount As Integer
    FinalCount = Count
    Count = 0
    ' Iterate through the sheets.
    For Each oSheet In oDocIDW.Sheets

oSheet.Activate

a = Count
b = Count + 1
c = Count + 2
    Set oTitleBlock = oSheet.TitleBlock

Dim sPromptStrings(0 To 3) As String
sPromptStrings(0) = TitleBlockArray(a)
sPromptStrings(1) = TitleBlockArray(b)
sPromptStrings(2) = TitleBlockArray(c)
sPromptStrings(3) = ""
'Puts Titleblock back in to sheet
Set oTitleBlock = oSheet.AddTitleBlock("ANSI A", , sPromptStrings)
Count = Count + 3
Next
End If

    Exit Sub
   
End Sub