VBA Replace title block definitions in drawing from template file

[pball]

I have some code to replace the current title block with a title block from a template file. I just don't like how it adds a new title block definition named "copy of titleblock". I'd like to delete or replace the current title block definition so only the newly added one is listed.

Sub test()
    Dim odrawdoc As DrawingDocument
    Set odrawdoc = ThisApplication.ActiveDocument

    If (odrawdoc.DocumentType <> kDrawingDocumentObject) Then Exit Sub
    
    Dim oTemplate As DrawingDocument
    Dim oSourceTitleBlockDef As TitleBlockDefinition
    Dim oNewTitleBlockDef As TitleBlockDefinition
    Dim oSheet As Sheet
    
    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & "template.idw", False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc)
    
    ' Iterate through the sheets.
    For Each oSheet In odrawdoc.Sheets
        oSheet.Activate
        oSheet.TitleBlock.Delete
        Call oSheet.AddTitleBlock(oNewTitleBlockDef)
    Next
    oTemplate.Close
End Sub

 I'm just being picky at this point, but I don't want a buildup of title block definitions. We reuse drawings all the time which is why a simple method of updating a title block would be nice. I can just imagine in some years time after a title block update or two there are 20 "copy of copy of copy of .................. titleblock" listed in a drawing file.

[mrattray]

You could try something like this (I didn't test it, just edited what you pasted):

Sub test()
    Dim odrawdoc As DrawingDocument
    Set odrawdoc = ThisApplication.ActiveDocument

    If (odrawdoc.DocumentType <> kDrawingDocumentObject) Then Exit Sub
    
    Dim oTemplate As DrawingDocument
    Dim oSourceTitleBlockDef As TitleBlockDefinition
    Dim oNewTitleBlockDef As TitleBlockDefinition
    Dim oSheet As Sheet
    
    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & "template.idw", False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition

    ' Iterate through the sheets.
    For Each oSheet In odrawdoc.Sheets
        oSheet.Activate
        oSheet.TitleBlock.Delete
    Next
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc)
    For Each oSheet In odrawdoc.Sheets
        oSheet.Activate
        Call oSheet.AddTitleBlock(oNewTitleBlockDef)
    Next

    oTemplate.Close
End Sub

 I'm not sure if you need to activate each sheet before you delete/add titleblocks, have you tried using this with the oSheet.Activate commented out? It will run much faster if you can get away without it.

[pball]

That's just about perfect there. I just had to add a line to delete the title block definition between the part removing the current title block and then copying the new one in. After looking over your code and playing around some more it hit me you have to remove the current title block from all sheets before you can delete it, which was my problem with what I tried before.

So the last part ends up like this.

 Sub Update_TitleBlock()
    Dim odrawdoc As DrawingDocument
    Set odrawdoc = ThisApplication.ActiveDocument

    If (odrawdoc.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
    
    Set oSheet = odrawdoc.ActiveSheet
    
    If (oSheet.TitleBlock.name = "ASSY") Then
        titlename = "ASSY"
        fname = "D_ASSY.idw"
    ElseIf (oSheet.TitleBlock.name = "TOLERANCE") Then
        titlename = "TOLERANCE"
        fname = "D_DET.idw"
    Else:
        MsgBox "This drawing has an unknown title block"
        Exit Sub
    End If
    
    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    
    ' Iterate through the sheets.
    For Each oSheet In odrawdoc.Sheets
        oSheet.TitleBlock.Delete
    Next
    
    odrawdoc.TitleBlockDefinitions.Item(titlename).Delete
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc)
    
    For Each oSheet In odrawdoc.Sheets
        Call oSheet.AddTitleBlock(oNewTitleBlockDef)
    Next
    oTemplate.Close
End Sub

 There is also a bit of extra I didn't include before, which works with the part or assembly title block.

[mrattray]

---

@pball wrote:

I just had to add a line to delete the title block definition between the part removing the current title block and then copying the new one in.

---

Oops, looks like I cut it and forgot to paste it. I'm glad you got it working, anyways.

It's a good rule of thumb with these things to have your code emulate what you would be doing through the UI. Generally, if you can't do it through the UI then you'll get an error when you try to do it with code. In fact, I would even recommend for the future that you do a trial run of something you want to code and document every step you have to take, as your code will have to follow a similar sequence and will have the same limitations.

[pball]

I always think out my scripts, some more than others though. Smaller things like this I tend to fly by the seat of my pants (which isn't always the best), but I've made some long flow chart like things for some of my larger scripts. Really helps plans the logic and finding common parts that can be turned into functions and such.

[Rene-J]

Hi

you do not need to delete the tilteblock

there is a replace function

True will replace , False will copy,

Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc,True)

Have you check this free addin.

Automatic update Drawing Resources 

http://www.mcadforums.com/forums/viewtopic.php?f=34&t=8018

 Rene J

[pball]

Thanks for the tip. I was able to switch back to my original code with that argument added and it works great. Well other than the occasional error adding the title block back in on multisheet drawings. Only seems to happen on a few when I don't activate sheets. Might just have to have it activate all sheets, it's not that much slower even on larger assembly drawings. Or after writing all of that I went and added an on error, which activates the current sheet on an error. Which is doing the trick nicely.

About the addin, I see two reasons I probably won't start using them in general. From what I read this addin automatically updates drawings when opened, definitely don't want to do that since certain things have edited title blocks. For addins in general it seems you have to install them, which I figure the others in my department wouldn't do. Most of them won't even manually replace a title block, lol.

Final code (for now)

Sub Update_TitleBlock()
    On Error GoTo ErrHandler:
    
    Dim odrawdoc As DrawingDocument
    Set odrawdoc = ThisApplication.ActiveDocument

    If (odrawdoc.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
    
    Set oSheet = odrawdoc.ActiveSheet
    
    If (oSheet.TitleBlock.name = "ASSY") Then
        titlename = "ASSY"
        fname = "D_ASSY.idw"
    ElseIf (oSheet.TitleBlock.name = "TOLERANCE") Then
        titlename = "TOLERANCE"
        fname = "D_DET.idw"
    Else:
        MsgBox "This drawing has an unknown title block"
        Exit Sub
    End If
    
    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False)
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc, True)
    
    ' Iterate through the sheets.
    For Each oSheet In odrawdoc.Sheets
        'oSheet.Activate if error occurs
        oSheet.TitleBlock.Delete
        Call oSheet.AddTitleBlock(oNewTitleBlockDef)
    Next
    oTemplate.Close
    
    Exit Sub
ErrHandler:
    oSheet.Activate
    Resume
End Sub

[mrattray]

I would recommend you move the on error statement to just before the for each sheet loop. This will make debugging easier if you have a problem with the code somewhere before that.

[pball]

Thanks. Haven't used on error much so doing that completely slipped my mind.

[Anonymous]

I would like to know why I have an error when I am at line:

Call oSheet.AddTitleBlock(oNewTitleBlockDef)

 It returns me an Run-time error '5' all the time. The rest goes very well. Thanks for your help

[tmuel]

I realize this is an old thread, but happen to be working on something similar and someone else may find it useful.
 
As @Rene-J was kind enough to point out, there is a replace function that can be used instead of delete.

Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc,True)

If this is used; it is the same as if it's done through the UI. Copying the drawing resources from one drawing to another and choosing the option to replace (assuming they have the same name). The TB definition replaces all occurrences on all sheets and will keep the individual prompted text property values (assuming the prompted text properties have the same name).

From the code posted earlier, I was getting the same "Run-time error 5". I think it was because it was trying to replace an identical instance of the TB on subsequent sheets (but that's just my best guess).

I removed the for each loop and oSheet.Activate and everything is working perfectly.

    ...End If

    Set oTemplate = ThisApplication.Documents.Open(ThisApplication.FileOptions.TemplatesPath & fname, False) 'open visible = false
    Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
    Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc, True) 'True will replace titleblock at destination with TB from source

    oTemplate.Close

End Sub