Change Template and Styles with Ilogic

[J.Classens]

Hello,

I have changed a Ilogic rule i have found to change the template and styles from a drawing.

The only thing that isn't working is exchanging the border.  

I can't find the fault in this rule.

Sub Main

If ThisDoc.Document.DocumentType <> kDrawingDocumentObject Then
	MsgBox("This rule may only be run on drawing documents!",vbOKOnly,"Update Everything")
	Exit Sub
End If
Dim oPrompt As String
oPrompt = MsgBox("Update Titleblocks and Styles?", vbYesNo, "Update Everything")

Select Case oPrompt
	Case vbNo
		Exit Sub
	Case vbYes
		'MessageBox.Show("START", "Title")

		ImportTemplateItems() 'Copy all stuf over from the Template file. 
		'MessageBox.Show("Import OK", "Title")
		
		ReplaceTitleBlock() 'Replace the current Titleblock with the new Titleblock on all sheets.
		'MessageBox.Show("TitleBlock OK", "Title")
		
		ReplaceBorder() 'Replace the current border with the new border on all sheets.
	       'MessageBox.Show("Border OK", "Title")
		
		SetActiveStyle() 'Set the Relco Global Style as active. 
		'MessageBox.Show("Set Active Style OK", "Title")

		PurgeStyles()
		'MessageBox.Show("PurgeStyle", "Title")

		DimensionUpdates()
'		'MessageBox.Show("Change Dim OK", "Title")

		
End Select

End Sub

Sub ImportTemplateItems()
Dim oTargetDoc, oSourceDoc As DrawingDocument
Dim oTBdef As TitleBlockDefinition
Dim oTBdefs As TitleBlockDefinitions
Dim oBorderDef As BorderDefinition
Dim oBorderDefs As BorderDefinitions
Dim oSymbol As SketchedSymbolDefinition
Dim oSymbols As SketchedSymbolDefinitions



oTargetDoc = ThisDrawing.Document

oSourceDoc = ThisApplication.Documents.Open("K:\Inventor\Inventor settings\Templates\Part.idw", False)

'oTargetDoc.StylesManager.ActiveStandardStyle.UpdateFromGlobal 'TURNED OF BECAUSE OF CONFLICT. Why is this broken?

oTBdefs = oSourceDoc.TitleBlockDefinitions
oBorderDefs = oSourceDoc.BorderDefinitions
oSymbols = oSourceDoc.SketchedSymbolDefinitions

For Each oTBdef In oTBdefs
	Try
		If oTBdef.Name = "(E) Manders" Then 'Make this string your new TitleBlock name
			oTBdef.CopyTo(oTargetDoc, True)
		End If
	Catch
		MsgBox("Unknown error in copy title block for " & Chr(34) & oTBdef.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next
For Each oBorderDef In oBorderDefs
	Try
		If oBorderDef.Name <> "Default Border" Then
			oBorderDef.CopyTo(oTargetDoc, True)
		End If
	Catch
		MsgBox("Unknown error in copy border definition for " & Chr(34) & oBorderDef.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next
For Each oSymbol In oSymbols
	Try
		oSymbol.CopyTo(oTargetDoc, True)
	Catch
		MsgBox("Unknown error in copy sketched symbol for " & Chr(34) & oSymbol.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next

oSourceDoc.Close()
End Sub

Sub ReplaceTitleBlock()
	
Dim i As Integer

'Replace Titleblock
Dim oTitle0 As String
oTitle0 = "(E) Manders" 'This should be the New Titleblock

' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

' Obtain a reference to the desired border defintion.
Dim oTitleBlockDef As TitleBlockDefinition
oTitleBlockDef = oDrawDoc.TitleBlockDefinitions.Item(oTitle0)

Dim oSheet As Sheet


'Count the number of total sheets
Dim SheetCount As Integer
SheetCount = oDrawDoc.Sheets.Count		

If (oDrawDoc.Sheets.Count > 0) Then 							'Execute if >1 sheets
	For Each s In oDrawDoc.Sheets
		s.Activate			'Activate sheet
		oSheet = oDrawDoc.ActiveSheet
		
		' Check to see if the sheet already has the correct title block and delete it if it doesn't.
		If Not oSheet.TitleBlock Is oTitle0 Then
			oSheet.TitleBlock.Delete
		End If
		Dim oTitleBlock As TitleBlock
		oTitleBlock = oSheet.AddTitleBlock(oTitleBlockDef)
	Next
Else 
	MessageBox.Show("There is only 1 Sheet. Make more sheets and come back", "Nothing to do")
End If
	
End Sub

Sub ReplaceBorder()
	
Dim i As Integer

'Replace border
Dim oBorder0 As String
oBorder0 = "Default Border" 'This should be the New Border

' Set a reference To the drawing document.
'This assumes a drawing document Is active.
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

' Obtain a reference To the desired border defintion.
Dim oBorderDef As BorderDefinition
oBorderDef = oDrawDoc.BorderDefinitions.Item(oBorder0)

Dim oSheet As Sheet

'Count the number Of total sheets
Dim SheetCount As Integer
SheetCount = oDrawDoc.Sheets.Count		

If (oDrawDoc.Sheets.Count > 0) Then 							'Execute if >1 sheets
	For Each s In oDrawDoc.Sheets
		s.Activate			'Activate sheet
		oSheet = oDrawDoc.ActiveSheet
		
'		 Check To see If the Sheet already has the correct Border And delete it If it doesn't.
		If Not oSheet.Border Is oBorder0 Then
		oSheet.Border.Delete
			
		End If
		Dim oBorder As Border
		oBorder = oSheet.AddBorder(oBorderDef)
	Next
Else 
	MessageBox.Show("There is only 1 Sheet. Make more sheets and come back", "Nothing to do")
End If
	
End Sub


Sub PurgeStyles()
	
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

Dim oStyles
oStyles = oDrawDoc.StylesManager

Dim noneleft As Boolean
noneleft = True

Dim ostyle As Style

Do While (noneleft)
	noneleft = False
	For Each ostyle In oStyles.Styles
		If (ostyle.StyleLocation = "51202") And (ostyle.InUse = False) Then
			ostyle.Delete
			noneleft = True
		End If
	Next
Loop
End Sub


Sub SetActiveStyle()
    Const kStandardName = "Manders 2021"
    Const kObjDefaultsName = "Verwijzingen Manders (engels)"
    Dim oDoc As DrawingDocument
   
    On Error Resume Next
   
    oDoc = ThisApplication.ActiveDocument
    Dim oStylesMgr As DrawingStylesManager
   
    oStylesMgr = oDoc.StylesManager
    Dim oStandard As DrawingStandardStyle
   
    oStandard = oStylesMgr.StandardStyles _
                             .Item(kStandardName)
   
    If oStandard Is Nothing Then
    oStandard = oStylesMgr.StandardStyles _
                       .Item(1).Copy(kStandardName)
    End If
   
    ' create object defaults
    Dim oObjDefaults As ObjectDefaultsStyle
    oObjDefaults = oStylesMgr. _
          ObjectDefaultsStyles.Item(kObjDefaultsName)
   
    If oObjDefaults Is Nothing Then
    oObjDefaults = oStylesMgr. _
         ObjectDefaultsStyles.Item(1). _
                  Copy(kObjDefaultsName)
    End If
   
    oStandard.ActiveObjectDefaults = oObjDefaults
   ' activate standard
    oStylesMgr.ActiveStandardStyle = oStandard

End Sub

Private Sub DimensionUpdates()
	Dim oDoc As DrawingDocument
 	oDoc = ThisApplication.ActiveDocument
	Dim oDim As GeneralDimension 
	Dim oDimStyle As DrawingStandardStyle
	Dim oSheet As Sheet
	oDimStyle = oDoc.StylesManager.ActiveStandardStyle

	For Each oSheet In oDoc.Sheets
		For Each oDim In oSheet.DrawingDimensions

			If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.AngularDimensionStyle.Name Then
				oDim.Style = oDimStyle.ActiveObjectDefaults.AngularDimensionStyle
			End If
			If oDimStyle.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionStyle.Name Then
				oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionStyle
			End If
			
		Next
	Next
End Sub

[Michael.Navara]

This part of code can't work

' Check to see if the sheet already has the correct title block and delete it if it doesn't.
If Not oSheet.TitleBlock Is oTitle0 Then
	oSheet.TitleBlock.Delete
End If
Dim oTitleBlock As TitleBlock
oTitleBlock = oSheet.AddTitleBlock(oTitleBlockDef)

Because oSheet.TitleBlock is Inventor.TitleBlock and oTitle0 is string. This condition is always FALSE. Then you can't add titleblock if old one exists.

You need to check  oSheet.TitleBlock.Name = oTitle0

The same situation is in Border replacing.

[J.Classens]

Thank's the test i have done the titleblocks names doesn't match so  it wasn't a problem. 

I have changed it to prevent future problems to occur. 

Unfortunately this doesn't fix my border problem.

It deletes the border but doesn't add the default one. 

[A.Acheson · Accepted solution]

This one was puzzling me as well. It looks like the "Default Border" has it's own method for being adding and you cannot add it by the BorderDefinition. The API help shows that. You can also use the ilogic snippet to do this for you. 

                'ActiveSheet.Border = oBorder0 'iLogic Snippet
		Dim oBorder As Border
		oBorder = oSheet.AddDefaultBorder

[fidel.makatiaD5W7V]

Hi @J.Classens , kindly go through the following code from Inventor docs. It shows you how to import an AutoCAD template and also keep default borders

Inventor 2022 Help | AutoCAD block definitions import | Autodesk

Let me know if it works or in case f any clarifications

[m.van.valen_ECO]

perhaps you can use this rule:

Sub Main()
    Dim oAsmDoc As AssemblyDocument = ThisApplication.ActiveDocument
	Dim oDoc As DrawingDocument
	ThisApplication.SilentOperation = True
   	TraverseAssembly_ReplaceDWGs(oAsmDoc.ComponentDefinition.Occurrences, 1)
	
	strFilename = System.IO.Path.GetDirectoryName(oAsmDoc.FullFileName) & "\" & System.IO.Path.GetFileNameWithoutExtension(oAsmDoc.FullFileName) & ".dwg"
	If System.IO.File.Exists(strFilename) Then
		oDoc = ThisApplication.Documents.Open(strFilename, False)
		GetTitleBlock(oDoc)
		SetActiveStyle(oDoc)
		UpdateStyles(oDoc)
		PurgeStyles(oDoc)
		oDoc.update2()
		oDoc.SaveAs(System.IO.Path.ChangeExtension(strFilename, ".idw"), True)
		oDoc.Close
		System.IO.File.Delete(strFilename)
	End If
	ThisApplication.SilentOperation = False
End Sub

Private Sub TraverseAssembly_ReplaceDWGs(Occurrences As ComponentOccurrences, Level As Integer)
    Dim oOcc As ComponentOccurrence
	Dim strFilename As String
    Dim oDoc As Document
	For Each oOcc In Occurrences
      	strFilename = System.IO.Path.GetDirectoryName(oOcc.Definition.Document.fullfilename) & "\" & System.IO.Path.GetFileNameWithoutExtension(oOcc.Definition.Document.fullfilename) & ".dwg"
        If System.IO.File.Exists(strFilename) Then
			oDoc = ThisApplication.Documents.Open(strFilename, False)
			GetTitleBlock(oDoc)
			SetActiveStyle(oDoc)
			UpdateStyles(oDoc)
			PurgeStyles(oDoc)
			oDoc.update2()			
			oDoc.SaveAs(System.IO.Path.ChangeExtension(strFilename, ".idw"), True)
			oDoc.Close
			System.IO.File.Delete(strFilename)
		End If
		If oOcc.DefinitionDocumentType = kAssemblyDocumentObject Then
            TraverseAssembly_ReplaceDWGs(oOcc.SubOccurrences, Level + 1)
        End If
    Next
End Sub
Sub GetTitleBlock(oDoc As DrawingDocument)
	Dim strTemplatePath As String = ThisApplication.DesignProjectManager.ActiveDesignProject.TemplatesPath & "Standard.idw"
	Dim TemplateDoc As Document = ThisApplication.Documents.Open(strTemplatePath, False)
    TemplateTitleBlock = TemplateDoc.TitleBlockDefinitions.Item(1)
    oBlock = TemplateTitleBlock.CopyTo(oDoc, True)
	TemplateDoc.close
	Dim oSheets As Sheets = oDoc.Sheets
	For Each oSheet As Inventor.Sheet In oSheets
		'TITLE
		oSheet.Activate
		oSheet.TitleBlock.Delete()
		oSheet.AddTitleBlock(oBlock)
		
		'BORDER
		If Not oSheet.Border Is Nothing Then oSheet.Border.Delete()
		Dim HorizontalZoneCount As Long = 15
        Dim HorizontalZoneLabelMode As BorderLabelModeEnum = kBorderLabelModeNumeric
        Dim VerticalZoneCount As Long = 10
        Dim VerticalZoneLabelMode As BorderLabelModeEnum = kBorderLabelModeAlphabetical
        Dim LabelFromBottomRight As Boolean = False
        Dim DelimitByLines As Boolean = True
        Dim CenterMarks As Boolean = False
        Dim TopMargin As Double = 0.5
        Dim BottomMargin As Double = 0.5
        Dim LeftMargin As Double = 1
        Dim RightMargin As Double = 0.5
        Dim BorderLineWidth As Double = 0.1
        Dim TextLabelHeight As Double = 1.5
        Dim Font As String = "Courier New"
        'Dim oBorder As DefaultBorder = oSheet.AddDefaultBorder(HorizontalZoneCount, HorizontalZoneLabelMode, VerticalZoneCount, VerticalZoneLabelMode, LabelFromBottomRight, DelimitByLines, CenterMarks, TopMargin, BottomMargin, LeftMargin, RightMargin, BorderLineWidth, TextLabelHeight, Font)
    	Dim oBorder As DefaultBorder = oSheet.AddDefaultBorder(, HorizontalZoneLabelMode, ,VerticalZoneLabelMode , LabelFromBottomRight, , CenterMarks, TopMargin, BottomMargin, LeftMargin, RightMargin,,,)
	Next

End Sub

Sub SetActiveStyle(oDoc As DrawingDocument)
	Const kStandardName = "Econvert" ' This is the name of the Style Standard
	Const kObjDefaultsName = "Object Defaults (Econvert)"  'This is the name of the Object Standard
	Dim oStylesMgr As DrawingStylesManager
	oStylesMgr = oDoc.StylesManager
	Dim oStandard As DrawingStandardStyle
	oStandard = oStylesMgr.StandardStyles.Item(kStandardName)

	If oStandard Is Nothing Then
		oStandard = oStylesMgr.StandardStyles.Item(1).Copy(kStandardName)
	End If
	oStylesMgr.ActiveStandardStyle = oStandard
End Sub

Sub UpdateStyles(oDoc As DrawingDocument)
For Each oStyle In oDoc.StylesManager.Styles
	If oStyle.UpToDate = False Then
		oStyle.UpdateFromGlobal()
	End If
Next
End Sub

Sub PurgeStyles(oDoc As DrawingDocument)
	oStyles = oDoc.StylesManager
	Dim noneleft As Boolean
	noneleft = True

	Do While (noneleft)
		noneleft = False
		For Each ostyle In oStyles.Styles
			If (ostyle.StyleLocation = "51202") And (ostyle.InUse = False) Then
				Try
					ostyle.Delete
					noneleft = True
				Catch
				End Try
			End If
		Next
	Loop
End Sub

[J.Classens]

Thanks for all the information.

The solution of @A.Acheson does the trick. 

Maybe you could help with another problem in this code.

I have added another private sub to check the file extension. 

If it isn't a .idw it will save the updated file with the right extension.

Some files are already in the right extension. The code provides an error when is is happening.

I cant get an if else function to solve this problem. 

Private Sub ExtensionUpdates()
 
ThisDoc.Document.SaveAs(ThisDoc.ChangeExtension(".idw"), True)
MessageBox.Show(ThisDoc.FileName(False) & ".idw  Saved!! " & vbCrLf & vbCrLf & ThisDoc.Path, "Save As")


End Sub

 I have tried

Private Sub ExtensionUpdates()
 'check file type
If ThisDoc.Document.SaveAs(ThisDoc.ChangeExtension(".idw"), True) Then
MessageBox.Show(ThisDoc.FileName(False) & ".idw  Saved!! " & vbCrLf & vbCrLf & ThisDoc.Path, "Save As")
Else 
ThisDoc.Document.SaveAs(ThisDoc.ChangeExtension(".idw"), False)
MessageBox.Show(ThisDoc.FileName(False) & "file is allready an .idw ")
End If

End Sub

[A.Acheson · Accepted solution]

The easiest way is use the Sytem.IO get extension method found here.  You can also shorten it to IO.Path....

Dim extension As String
extension = System.IO.Path.GetExtension(ThisDoc.PathAndFileName(True))
MessageBox.Show(extension, "iLogic")

[J.Classens]

That works! Thanks

The last problem that the code is having is updating the parts list.

This is a function i have added in the complete code.  

I can't find the problem, do you have any thoughts? 

Sub Main

If ThisDoc.Document.DocumentType <> kDrawingDocumentObject Then
	MsgBox("This rule may only be run on drawing documents!",vbOKOnly,"Update Everything")
	Exit Sub
End If
Dim oPrompt As String
oPrompt = MsgBox("Update Titleblocks and Styles?", vbYesNo, "Update Everything")

Select Case oPrompt
	Case vbNo
		Exit Sub
	Case vbYes
		'MessageBox.Show("START", "Title")

		ImportTemplateItems() 'Copy all stuf over from the Template file. 
		'MessageBox.Show("Import OK", "Title")
		
		ReplaceTitleBlock() 'Replace the current Titleblock with the new Titleblock on all sheets.
		'MessageBox.Show("TitleBlock OK", "Title")
		
		ReplaceBorder() 'Replace the current border with the new border on all sheets.
'		'MessageBox.Show("Border OK", "Title")
		
		SetActiveStyle() 'Set the Relco Global Style as active. 
		'MessageBox.Show("Set Active Style OK", "Title")

		PurgeStyles()
		'MessageBox.Show("PurgeStyle", "Title")

		DimensionUpdates()
'		'MessageBox.Show("Change Dim OK", "Title")

	        PartListUpdates()

		ExtensionUpdates()

		
End Select

End Sub

Sub ImportTemplateItems()
Dim oTargetDoc, oSourceDoc As DrawingDocument
Dim oTBdef As TitleBlockDefinition
Dim oTBdefs As TitleBlockDefinitions
Dim oBorderDef As BorderDefinition
Dim oBorderDefs As BorderDefinitions
Dim oSymbol As SketchedSymbolDefinition
Dim oSymbols As SketchedSymbolDefinitions



oTargetDoc = ThisDrawing.Document

oSourceDoc = ThisApplication.Documents.Open("K:\Inventor\Inventor settings\Templates\Weldment.idw", False)

'oTargetDoc.StylesManager.ActiveStandardStyle.UpdateFromGlobal 'TURNED OF BECAUSE OF CONFLICT. Why is this broken?

oTBdefs = oSourceDoc.TitleBlockDefinitions
oBorderDefs = oSourceDoc.BorderDefinitions
oSymbols = oSourceDoc.SketchedSymbolDefinitions

For Each oTBdef In oTBdefs
	Try
		If oTBdef.Name = "(E) Manders 2021" Then 'Make this string your new TitleBlock name
			oTBdef.CopyTo(oTargetDoc, True)
		End If
	Catch
		MsgBox("Unknown error in copy title block for " & Chr(34) & oTBdef.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next
For Each oBorderDef In oBorderDefs
	Try
		If oBorderDef.Name <> "Default Border" Then
			oBorderDef.CopyTo(oTargetDoc, True)
		End If
	Catch
		MsgBox("Unknown error in copy border definition for " & Chr(34) & oBorderDef.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next
For Each oSymbol In oSymbols
	Try
		oSymbol.CopyTo(oTargetDoc, True)
	Catch
		MsgBox("Unknown error in copy sketched symbol for " & Chr(34) & oSymbol.Name & Chr(34),vbOKOnly,"Error")
	End Try
Next

oSourceDoc.Close()
End Sub

Sub ReplaceTitleBlock()
	
Dim i As Integer

'Replace Titleblock
Dim oTitle0 As String
oTitle0 = "(E) Manders 2021" 'This should be the New Titleblock

' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

' Obtain a reference to the desired border defintion.
Dim oTitleBlockDef As TitleBlockDefinition
oTitleBlockDef = oDrawDoc.TitleBlockDefinitions.Item(oTitle0)

Dim oSheet As Sheet


'Count the number of total sheets
Dim SheetCount As Integer
SheetCount = oDrawDoc.Sheets.Count		

If (oDrawDoc.Sheets.Count > 0) Then 							'Execute if >1 sheets
	For Each s In oDrawDoc.Sheets
		s.Activate			'Activate sheet
		oSheet = oDrawDoc.ActiveSheet
		
		' Check to see if the sheet already has the correct title block and delete it if it doesn't.
		If Not oSheet.TitleBlock.Name Is oTitle0 Then
			oSheet.TitleBlock.Delete
		End If
		Dim oTitleBlock As TitleBlock
		oTitleBlock = oSheet.AddTitleBlock(oTitleBlockDef)
	Next
Else 
	MessageBox.Show("There is only 1 Sheet. Make more sheets and come back", "Nothing to do")
End If
	
End Sub

Sub ReplaceBorder()
	
Dim i As Integer

'Replace border
Dim oBorder0 As String
oBorder0 = "Default Border" 'This should be the New Border

' Set a reference To the drawing document.
'This assumes a drawing document Is active.
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

' Obtain a reference To the desired border defintion.
Dim oBorderDef As BorderDefinition
oBorderDef = oDrawDoc.BorderDefinitions.Item(oBorder0)

Dim oSheet As Sheet

'Count the number Of total sheets
Dim SheetCount As Integer
SheetCount = oDrawDoc.Sheets.Count		

If (oDrawDoc.Sheets.Count > 0) Then 							'Execute if >1 sheets
	For Each s In oDrawDoc.Sheets
		s.Activate			'Activate sheet
		oSheet = oDrawDoc.ActiveSheet
		
'		 Check To see If the Sheet already has the correct Border And delete it If it doesn't.
		If Not oSheet.Border.Name Is oBorder0 Then
		oSheet.Border.Delete
			
		End If
		Dim oBorder As Border
		oBorder = oSheet.AddDefaultBorder
	Next
Else 
	MessageBox.Show("There is only 1 Sheet. Make more sheets and come back", "Nothing to do")
End If
	
End Sub


Sub PurgeStyles()
	
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.ActiveDocument

Dim oStyles
oStyles = oDrawDoc.StylesManager

Dim noneleft As Boolean
noneleft = True

Dim ostyle As Style

Do While (noneleft)
	noneleft = False
	For Each ostyle In oStyles.Styles
		If (ostyle.StyleLocation = "51202") And (ostyle.InUse = False) Then
			ostyle.Delete
			noneleft = True
		End If
	Next
Loop
End Sub


Sub SetActiveStyle()
    Const kStandardName = "Manders 2021 Weldment"
    Const kObjDefaultsName = "Verwijzingen Manders (engels)"
	Const kPartsListName = "Manders 2021 weldment"
	
    Dim oDoc As DrawingDocument
   
    On Error Resume Next
   
    oDoc = ThisApplication.ActiveDocument
    Dim oStylesMgr As DrawingStylesManager
   
    oStylesMgr = oDoc.StylesManager
    Dim oStandard As DrawingStandardStyle
   
    oStandard = oStylesMgr.StandardStyles _
                             .Item(kStandardName)
   
    If oStandard Is Nothing Then
    oStandard = oStylesMgr.StandardStyles _
                       .Item(1).Copy(kStandardName)
    End If
   
    ' create object defaults
    Dim oObjDefaults As ObjectDefaultsStyle
    oObjDefaults = oStylesMgr. _
          ObjectDefaultsStyles.Item(kObjDefaultsName)
   
    If oObjDefaults Is Nothing Then
    oObjDefaults = oStylesMgr. _
         ObjectDefaultsStyles.Item(1). _
                  Copy(kObjDefaultsName)
    End If
   'create part list 
       Dim oPartList As PartsList
    oPartList = oStylesMgr. _
          PartsLists.Item(kPartListName)
   
    If oPartList Is Nothing Then
    oPartList = oStylesMgr. _
         PartsLists.Item(1). _
                  Copy(kPartListName)
    End If
	' activate standard
	oStylesMgr.ActiveStandardStyle = oStandard
    oStandard.ActiveObjectDefaults = oObjDefaults
   	oStandard.ActivePartsLists = oPartList
    

End Sub

Private Sub DimensionUpdates()
	Dim oDoc As DrawingDocument
 	oDoc = ThisApplication.ActiveDocument
	Dim oDim As GeneralDimension 
	Dim oDimStyle As DrawingStandardStyle
	Dim oSheet As Sheet
	oDimStyle = oDoc.StylesManager.ActiveStandardStyle

	For Each oSheet In oDoc.Sheets
		For Each oDim In oSheet.DrawingDimensions

			If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.AngularDimensionStyle.Name Then
				oDim.Style = oDimStyle.ActiveObjectDefaults.AngularDimensionStyle
			End If
			If oDimStyle.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionStyle.Name Then
				oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionStyle
			End If
			
		Next
	Next
End Sub

Private Sub PartListUpdates()
    Dim oDoc As DrawingDocument
    oDoc = ThisApplication.ActiveDocument
    
    Dim oStyleMgr As DrawingStylesManager
    oStyleMgr = oDoc.StylesManager
    
    Dim oPartListStyle As PartsListStyle
    oPartListStyle = oStyleMgr.PartsListStyles.Item("Manders 2021 Weldment")
    'oPartListStyle = oDoc.StylesManager.ActiveStandardStyle
    Dim oPartsList As PartsList
    For Each oPartsList In oDoc.ActiveSheet.PartsLists
        oPartsList.Style = oPartListStyle
    Next
End Sub

Private Sub ExtensionUpdates()
 'check file type
 Dim extension As String
extension = System.IO.Path.GetExtension(ThisDoc.PathAndFileName(True))


If extension = ".idw" Then
MessageBox.Show("File allready .idw", "iLogic")	
Else

ThisDoc.Document.SaveAs(ThisDoc.ChangeExtension(".idw"), True)
MessageBox.Show(ThisDoc.FileName(False) & ".idw  Saved!! " & vbCrLf & vbCrLf & ThisDoc.Path, "Save As")
End If


End Sub

[A.Acheson]

Do you know what the error is with the partslist? Is it not updating the style? Or is it the partslist missing and not being added etc? A reference to it is coming up in two places in the Sub SetActiveStyle()

and in the Private Sub PartListUpdates()

[J.Classens]

The part list isn't added in the style.

So it can't be added later in de code because it isn't there. 

[A.Acheson]

Here is two links on adding a partslists. The first one is from the API help. 

https://help.autodesk.com/view/INVNTOR/2021/ENU/?guid=GUID-5B02B07C-FAEA-4107-A3AD-F6FFC317D134

This one fills in the blanks on positioning the partlist on the drawing sheet. Also a point to note I think there can be an issue setting the style as it is being placed so you will need to set the style using the default style or index of 1 then set then cycle the style to either the styles in the drawing or from the styles manager. 

https://forums.autodesk.com/t5/inventor-forum/ilogic-generate-parts-list/td-p/3646032