Private Sub BorderTitleBlock()
Dim oIDWDoc As DrawingDocument
Set oIDWDoc = ThisApplication.ActiveDocument
Dim oSourceFile As DrawingDocument
Dim oSheet As Sheet
Dim oTitleBlock
Dim SourceFileName As String
Dim ActiveTitleBlockName As String
Dim oTBDef As TitleBlockDefinition
Dim bFound As Boolean
For Each oSheet In oIDWDoc.Sheets
Set oTitleBlock = oSheet.TitleBlock
ActiveTitleBlockName = oTitleBlock.Definition.Name
If ActiveTitleBlockName <> "HCTitleBlock Metric" Then
oTitleBlock.Delete
For Each oTBDef In oIDWDoc.TitleBlockDefinitions
If oTBDef.Name = "HCTitleBlock Metric" Then
bFound = True
Set oTitleBlock = oSheet.AddTitleBlock(oIDWDoc.TitleBlockDefinitions.Item("HCTitleBlock Metric"))
Exit For
End If
Next
If Not bFound Then
SourceFileName = "\\brisbane-fs01\CAD_SERV\Inventor\Templates9\Standard.idw"
Set oSourceFile = ThisApplication.Documents.Open(SourceFileName, False)
oIDWDoc.TitleBlockDefinitions.Add (oSourceFile.TitleBlockDefinitions("HCTitleBlock Metric")) 'this is incorrect... What should i have here?
Set oTitleBlock = oSheet.AddTitleBlock("HCTitleBlock Metric")
oSourceFile.Close
Set oSourceFile = Nothing
End If
End If
Next
End Sub
For Inventor 2010:
Delete old resources:
Dim oDocument As DrawingDocument
Dim oSheet As Sheet
Dim oPane As BrowserPane
Dim oDocumentNode As BrowserNode
Dim oDrawingResourceNode As BrowserNode
Dim oSheetFormatsNode As BrowserNode
Dim oBordersNode As BrowserNode
Dim oTitleBlocksNode As BrowserNode
Dim oSBsNode As BrowserNode
Set oDocument = ThisApplication.ActiveDocument 'Delete titleblock on sheet
If Not oDocument.ActiveSheet.TitleBlock Is Nothing Then
For Each oSheet In oDocument.Sheets
oSheet.TitleBlock.Delete
Next
End If
'Delete border on sheet
If Not oDocument.ActiveSheet.Border Is Nothing
Then
For Each oSheet In oDocument.Sheets
oSheet.Border.Delete
oSheet.AddDefaultBorder
Next
End If
oDocument.BrowserPanes.Item("Model").Activate
'Delete Drawing Resources
Set oPane = oDocument.BrowserPanes.ActivePane
Set oDocumentNode = oPane.TopNode
Set oDrawingResourceNode = oDocumentNode.BrowserNodes.Item("Drawing Resources") oDrawingResourceNode.DoSelect
'Delete Sheet Formats
Set oSheetFormatsNode = oDrawingResourceNode.BrowserNodes.Item("Sheet Formats")
For Each oSheetFormatsNode In oSheetFormatsNode.BrowserNodes
oSheetFormatsNode.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd").Execute
Next
'Delete Borders
Set oBordersNode = oDrawingResourceNode.BrowserNodes.Item("Borders")
For Each oBordersNode In oBordersNode.BrowserNodes
oBordersNode.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd").Execute
Next
'Delete Title Blocks
Set oTitleBlocksNode = oDrawingResourceNode.BrowserNodes.Item("Title Blocks")
For Each oTitleBlocksNode In oTitleBlocksNode.BrowserNodes
oTitleBlocksNode.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd").Execute
Next
'Delete Sketched Symbols
Set oSBsNode = oDrawingResourceNode.BrowserNodes.Item("Sketched Symbols")
For Each oSBsNode In oSBsNode.BrowserNodes
oSBsNode.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppDeleteCmd").Execute
Next
AddNewTitleblock
' Open the new drawing to copy the title block into.
Dim oDocument As DrawingDocument
Dim oSourceDocument As DrawingDocument
Dim oSourceTitleBlockDef As TitleBlockDefinition
Dim oNewTitleBlockDef As TitleBlockDefinition
Dim oSPane As BrowserPane
Dim aPane As BrowserPane
Dim oSNode As BrowserNode
Dim oSDRNode As BrowserNode
Dim oSTitle As BrowserNode
Dim aDocNode As BrowserNode
Dim aDrResNode As BrowserNode
Dim aTBNode As BrowserNode
Dim oSheet As Sheet
Set oDocument = ThisApplication.ActiveDocument
Set oSourceDocument = ThisApplication.Documents.Add(kDrawingDocumentObject, "\\foo\Inventor2010\Templates\Standard_ISO.idw", True)
Set oSourceTitleBlockDef = oSourceDocument.ActiveSheet.TitleBlock.Definition
Set oSPane = oSourceDocument.BrowserPanes.Item("Model")
Set oSNode = oSPane.TopNode
Set oSDRNode = oSNode.BrowserNodes.Item("Drawing Resources")
Set aPane = oDocument.BrowserPanes.ActivePane
Set aDocNode = aPane.TopNode
Set aDrResNode = aDocNode.BrowserNodes.Item("Drawing Resources")
' Kopiëer Title Blocks
oSourceDocument.Activate
Set oSTitle = oSDRNode.BrowserNodes.Item("Title Blocks")
oSTitle.EnsureVisible
oSTitle.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppCopyCmd").Execute
oDocument.Activate
aDrResNode.DoSelect
Set aTBNode = aDrResNode.BrowserNodes.Item("Title Blocks")
aTBNode.EnsureVisible
aTBNode.DoSelect ThisApplication.CommandManager.ControlDefinitions.Item("AppPasteCmd").Execute
' Kopiëer Sketched Symbols
oSourceDocument.Activate
Set oSTitle = oSDRNode.BrowserNodes.Item("Sketched Symbols")
oSTitle.EnsureVisible
oSTitle.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppCopyCmd").Execute
oDocument.Activate
aDrResNode.DoSelect
Set aTBNode = aDrResNode.BrowserNodes.Item("Sketched Symbols")
aTBNode.EnsureVisible
aTBNode.DoSelect
ThisApplication.CommandManager.ControlDefinitions.Item("AppPasteCmd").Execute
oSourceDocument.Close
' Get the new title block definition.
'Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(oDocument)
' Iterate through the sheets.
For Each oSheet In oDocument.Sheets
oSheet.Activate
Call oSheet.AddTitleBlock("ISO")
Next
Maybe there is a faster way?
Greetz Harm Uenk