Change Titleblock

Anonymous · ‎02-05-2016

I have put together a piece that performs these steps:

open part drawings as they appear on a parts list
add information to those part drawings from the parts list
send part drawings to a PDF printer
close file and go to next part in parts list

We have recently changed made a new part print template with a new titleblock. I would like this rule to check the title block and replace it if it isn't current (based on title block name). I have not found a way to do so. I can read the title block name. I can delete the title block from the open drawing. I cannot place a new title block. The ActiveSheet.TitleBlock command won't let the rule run because "Titleblock is ReadOnly". Help?

Allen

'Release 1.0 February 3, 2016
Imports System.IO

Sub Main()
ThisApplication.SilentOperation = True
ActiveSheet = ThisDrawing.Sheet("Cut Sheet:1")
Dim oDrawDoc As DrawingDocument = ThisApplication.ActiveDocument
Dim oDrawingView As DrawingView
Dim oSheet As Sheet = oDrawDoc.ActiveSheet
Dim oPartList As PartsList
Dim path As String
Dim PartNum As String
Dim FileLoc As New DirectoryInfo("C:\Yargus Working Folder\Projects")
PageNumber = 1
 
CoverSheetPage2:
oDrgPrintMgr = oDrawDoc.PrintManager
oDrgPrintMgr.Printer = "PDFCreator"
oDrgPrintMgr.PrintRange = kPrintCurrentSheet
oDrgPrintMgr.AllColorsAsBlack = False
oDrgPrintMgr.ScaleMode = kPrintBestFitScale 'oDrgPrintMgr.ScaleMode = kPrintModel
oDrgPrintMgr.ColorMode = kPrintDefaultColorMode
oDrgPrintMgr.PaperSize = SizeActiveSheet
oDrgPrintMgr.SubmitPrint

If PageNumber = 1 Then
	Try 
		ActiveSheet = ThisDrawing.Sheet("Cut Sheet:2")
		PageNumber = 2
		Goto CoverSheetPage2:
	Catch
	End Try
End If

ActiveSheet = ThisDrawing.Sheet("Cut Sheet:1")
PageNumber = 1


'Get information from text boxes in the sheet title
oTitleBlock = oSheet.TitleBlock
oTextBoxes = oTitleBlock.Definition.Sketch.TextBoxes
For Each oTextBox In oTextBoxes
	If oTextBox.Text = "<Work Order>" Then
		WO = oTitleBlock.GetResultText(oTextBox)
	End If
	If oTextBox.Text = "<Customer Info Line 1>" Then
		Customer = oTitleBlock.GetResultText(oTextBox)
	End If
	If oTextBox.Text = "<Customer Info Line 2>" Then
		Location = oTitleBlock.GetResultText(oTextBox)
	End If
	If oTextBox.Text = "<FILENAME>" Then
		Assy = oTitleBlock.GetResultText(oTextBox)
	End If
Next

CutSheetPage2:
If PageNumber = 2 Then
	Dim oSheet2 As Sheet = oDrawDoc.ActiveSheet
	oPartList = oSheet2.PartsLists(1)
Else If PageNumber = 1 Then
	oPartList = oSheet.PartsLists(1)
End If

For Each oPartListRow In oPartList.PartsListRows
	If oPartListRow.Visible = "True" And oPartListRow.Custom = "False" Then
		
		oCell = oPartListRow.Item(" QTY")
		QTY = oCell.Value
		oCell2 = oPartListRow.Item("LENGTH (in)")
		Length = oCell2.Value
		oCell3 = oPartListRow.Item("WIDTH (in)")
		Width = oCell3.Value
		oCell4 = oPartListRow.Item("PART NUMBER")
		PartNum = oCell4.Value & ".idw"
		
        path = SearchFile(FileLoc, PartNum, 0)
		
		If path <> "" Then
			ThisApplication.Documents.Open(path, True)
		Else If path = "" Then
			MessageBox.Show("The drawing was not found and will be omitted from the plot stamp.", "File Not found")
			Goto MOVEON:
		End If
		
		Dim oDrawDoc2 As DrawingDocument = ThisApplication.ActiveDocument
		
		'Place text with information for each drawing
		Dim oActiveSheet As Sheet
		oActiveSheet = oDrawDoc2.ActiveSheet
		
		TB = oActiveSheet.TitleBlock
		If TB.Name <> "Yargus 2016" Then
			MessageBox.Show("This drawing has an out of date drawing template. Please Review.", PartNum)
		End If
		
		'use PaperSizeEnum from inventor programming help
		PageSize = oActiveSheet.Size
		If PageSize = 9990 Then 'Size is ANSI D
			PageSize = 14347
		End If
		If PageSize = 9987 Then 'Size is Letter (A)
			PageSize = 14353
		End If
		If PageSize = 9988 Then 'Size is 11x17 (B)
			PageSize = 14338
		End If
		If PageSize = 9989 Then 'Size is ANSI C
			PageSize = 14346
		End If
		
		Dim oGeneralNotes As GeneralNotes
		oGeneralNotes = oActiveSheet.DrawingNotes.GeneralNotes
		Dim oTG As TransientGeometry
		oTG = ThisApplication.TransientGeometry
		Dim oGeneralNote As GeneralNote
		x=0
		If PageSize = 14347 Then
			x = 58.5
		Else If PageSize = 14346 Then
			x = 28
		Else If PageSize = 14338 Then
			x = 15.25
		End If
		
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(3.27+x, 4.28), QTY)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(7+x, 4.28), Assy)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(13.75+x, 4.28), WO)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(11.75+x, 3.65), Length)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(15.75+x, 3.65), Width)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(2.7+x, 2.95), Customer)
		oGeneralNote = oGeneralNotes.AddFitted(oTG.CreatePoint2d(11+x, 2.95), Location)
		
		'End insert text onto drawing
		
		oDrgPrintMgr2 = oDrawDoc2.PrintManager
		oDrgPrintMgr2.Printer = "PDFCreator"
		oDrgPrintMgr2.PrintRange = kPrintAllSheets
		oDrgPrintMgr2.AllColorsAsBlack = False
		oDrgPrintMgr2.ScaleMode = kPrintBestFitScale 'oDrgPrintMgr.ScaleMode = kPrintModel
		oDrgPrintMgr2.ColorMode = kPrintDefaultColorMode
		oDrgPrintMgr2.PaperSize = PageSize
		oDrgPrintMgr2.SubmitPrint
		oDrawDoc2.Close(True)

	End If
	MOVEON:
Next

If PageNumber = 1 Then
	Try 
		ActiveSheet = ThisDrawing.Sheet("Cut Sheet:2")
		PageNumber = 2
		Goto CutSheetPage2:
	Catch
	End Try
End If

ActiveSheet = ThisDrawing.Sheet("Cut Sheet:1")
MessageBox.Show("Plot Stamp Has Completed Successfully!", "Finished")

End Sub

    Function SearchFile(ByVal SearchDir As DirectoryInfo, ByVal searchFileName As String,i As Integer) As String
   		Static Dim FoundPath
		If i = 0 Then
			FoundPath = ""
			i = 1
		End If
		If FoundPath = "" Then
		Dim temp As String = ""
		If SearchDir.GetFiles(searchFileName).Length > 0 Then
		FoundPath = SearchDir.FullName & "\" & searchFileName
		Return SearchDir.FullName & "\" & searchFileName
		End If
		Dim Directories() As DirectoryInfo = SearchDir.GetDirectories("*")
		For Each newDir As DirectoryInfo In Directories
		temp = SearchFile(newDir, searchFileName,i)
		Next
		Return temp
		Else
		Return FoundPath		
		End If
	 End Function

Anonymous · ‎02-05-2016

just as a follow up, this is the method I've tried and was unsuccessful.

Anonymous · ‎02-12-2016

Here's what I use to update an old drawing with the most recent titleblock in the template. It's VBA, but you can maybe "translate" it.

-->

Public Sub TitleBlock_StylesCopy()

Dim oSource As String

' Location of Template
oSource = "--Insert your path here\MyTemplate.idw--"

Dim oActive As String
oActive = ThisApplication.ActiveDocument.fullFilename

Dim oSourceDocument As DrawingDocument
Set oSourceDocument = ThisApplication.Documents.Open(oSource)
' Open the new drawing to copy the title block into.
Dim oNewDocument As DrawingDocument
Set oNewDocument = ThisApplication.Documents.Open(oActive)

' Get the new source title block definition.
Dim oSourceTitleBlockDef As TitleBlockDefinition
oSourceDocument.Activate
Set oSourceTitleBlockDef = oSourceDocument.ActiveSheet.TitleBlock.Definition

' Get the new title block definition.
Dim oNewTitleBlockDef As TitleBlockDefinition
Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(oNewDocument)
oSourceDocument.Close (True)

' Iterate through the sheets.
Dim osheet As Sheet
For Each osheet In oNewDocument.Sheets
osheet.Activate

If Not osheet.TitleBlock Is Nothing Then
osheet.TitleBlock.Delete
End If

' I have no idea what this does

Dim sPromptStrings(1 To 3) As String
sPromptStrings(1) = ""
sPromptStrings(2) = ""
sPromptStrings(3) = ""
' Add an instance of the title block definition to the sheet.
Dim oTitleBlock As TitleBlock
Set oTitleBlock = osheet.AddTitleBlock(oNewTitleBlockDef, , sPromptStrings)
Next

'-------------------------------------------------------------------------------------------

Dim oDoc As DrawingDocument
Set oDoc = ThisApplication.ActiveDocument
On Error GoTo zzz

' Change to whatever style name you need
oDoc.StylesManager.ActiveStandardStyle = oDoc.StylesManager.StandardStyles("MyStandard")
If oDoc.StylesManager.ActiveStandardStyle.UpToDate = False Then
oDoc.StylesManager.ActiveStandardStyle.UpdateFromGlobal
End If
' MsgBox (oDoc.StylesManager.ActiveStandardStyle.Name & " is updated and activated)

Dim oTitleToDel As TitleBlockDefinition
For Each oTitleToDel In oNewDocument.TitleBlockDefinitions
If oTitleToDel.IsReferenced = False Then
oTitleToDel.Delete
End If
Next

Exit Sub
zzz:
MsgBox ("Style MyStyle is unavailable, you must import it first." & vbNewLine & Err.number)
End Sub

<--

Cheers

Anonymous · ‎02-12-2016

Thanks for the response. Actually, yesterday I found an example using the same method that you've shown and it is working for us.

Community

Change Titleblock

Change Titleblock

Change Titleblock