Update layers from template file (continued)

machiel.veldkamp · ‎08-31-2018

Hi!

I posted THIS yersterday. I figured out how to copy allmost all information from new template to old drawings but I'm now stuck on something new.

Layers!

Wrong colours

This is a screengrab of an old drawing that I need to convert.

Now. I have this code:

SyntaxEditor Code Snippet

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
			ImportTemplateItems() 'Copy all stuf over from the Template file. 
				'MessageBox.Show("Import OK", "Title")
			UpdatePartslist()
				'MessageBox.Show("Partslist OK", "Title")
			ReplaceTitleBlock() 'Replace the current Titleblock with the new Titleblock on all sheets.
				'MessageBox.Show("TitleBlock 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")	
			SheetColor()
	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("C:\Relco\Vault\CAD Standards\Inventor\RELCO Global Templates\Standard.dwg", True)

	'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 = "RELCO Global Rev 0" 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 = "Relco Global Rev 0" '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 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 = "RELCO Global" ' This is the name of the Style Standard
    Const kObjDefaultsName = "Relco Global Defaults"  'This is the name of the Object Standard
    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 
	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
	Dim oBalloon As Balloon

	For Each oSheet In oDoc.Sheets
		For Each oDim In oSheet.DrawingDimensions
			Try
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.AngularDimensionStyle.Name Then
					oDimStyle.ActiveObjectDefaults.
					oDim.Style = oDimStyle.ActiveObjectDefaults.AngularDimensionStyle
				End If
				
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionLayer.Name Then
					'oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionLayer
				End If
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.BaselineDimensionStyle.Name Then
					oDim.Style = oDimStyle.ActiveObjectDefaults.BaselineDimensionStyle
				End If
				
				
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionStyle.Name Then
					oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionStyle
				End If
				
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionStyle.Name Then
					oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionStyle
				End If
				If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.DiameterDimensionStyle.Name Then
					oDim.Style = oDimStyle.ActiveObjectDefaults.DiameterDimensionStyle
					
				End If
			Catch Ex As Exception 
				MessageBox.Show("Error. Ask Machiel What's up", "Title")
			End Try
			
		Next
		For Each oBalloon In oSheet.Balloons
			If oBalloon.Style.Name <> oDimStyle.ActiveObjectDefaults.BalloonStyle.Name Then
                oBalloon.Style = oDimStyle.ActiveObjectDefaults.BalloonStyle
            End If
        Next
	Next
	   
	
End Sub


Sub UpdatePartslist()
	Dim oDoc As DrawingDocument
    oDoc = ThisApplication.ActiveDocument
    Dim oStyleMgr As DrawingStylesManager
    oStyleMgr = oDoc.StylesManager
    Dim oPartListStyle As PartsListStyle
    oPartListStyle = oStyleMgr.PartsListStyles.Item("RELCO Global Parts List")
    Dim oSheet As Sheet
    Dim oPartsList As PartsList
	
	For Each oSheet In oDoc.Sheets
		For Each oPartsList In oSheet.PartsLists
			oPartsList.Style = oPartListStyle
	    Next
	Next
End Sub

Sub SheetColor()
Dim oDoc As DrawingDocument
oDoc = ThisApplication.ActiveDocument

Dim oSheetSettings As SheetSettings
oSheetSettings = oDoc.SheetSettings

Dim oColor As Color
oColor = ThisApplication.TransientObjects.CreateColor(237, 237, 214)

oSheetSettings.SheetColor = oColor
End Sub

So!

In DimensionUpdates() I tried getting the Layername from the template and put it in the new drawing but it error's out and it doesn;t seem to work!

If oDim.Style.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionLayer.Name Then
	oDim.Style = oDimStyle.ActiveObjectDefaults.LinearDimensionLayer
End If

Are you supposed to handle layers differently then Styles?

What am I doing wrong here?

I can't find much online. Help?

Did you find this reply helpful ? If so please use the Accept as Solution or Kudos button below.

___________________________

machiel.veldkamp · ‎08-31-2018

Ok. Dimensions were easy enough.

SyntaxEditor Code Snippet

If oDim.Layer.Name <> oDimStyle.ActiveObjectDefaults.LinearDimensionLayer.Name Then
	oDim.Layer = oDimStyle.ActiveObjectDefaults.LinearDimensionLayer
End If

Now on to drawingviews. Those seem harder?

Did you find this reply helpful ? If so please use the Accept as Solution or Kudos button below.

___________________________

Community

Update layers from template file (continued)

Update layers from template file (continued)

Update layers from template file (continued)