Title Block

[martinhoos]

Hello together,

i have a problem with Title Blocks, i like to change the titleblock in all sheets via iLogic. With this code it only changes in the active sheet.

My script is the following (By the way, i do nothing know about iLogic, i just copy together...):

Thank you very much

Regards Martin

ActiveSheet.TitleBlock = "ET-Liste Deutsch"

Dim openDoc As Document
openDoc = ThisDoc.Document
 
'Dim docFile As Document
 
If openDoc.DocumentType = 12292 Then
 
    'Look For the model referenced within the drawing. End the Rule If the drawing Is empty.
    Dim MDocFile As Document
    If ThisDoc.ModelDocument IsNot Nothing Then
         MDocFile = ThisDoc.ModelDocument
         Else
         MessageBox.Show("Diese Option ist in einer leeren Zeichnung unzulässig", "Export error")
         Return
    End If
    
    'assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    oDrawDoc = ThisApplication.ActiveDocument
        
    'Set a reference to the active sheet.
    Dim oSheet As Sheet
    oSheet = oDrawDoc.ActiveSheet
    'Look for partlist within drawing. End rule, if it doesn't exist.
    'say there is a Partslist on the sheet.
    Dim oPartslist As PartsList
    oPartslist = oSheet.PartsLists(1)
 
    If oSheet.PartsLists(1) IsNot Nothing Then
 
        'set parts list to a specific style
        oPartsList.Style = oDrawDoc.StylesManager.PartsListStyles.Item("KV-Stueli_Deutsch")
		ThisDrawing.Document.StylesManager.Layers("KV deutsch"​).Visible= True
		ThisDrawing.Document.StylesManager.Layers("KV englisch"​).Visible= False
 
     End If
        
        
    Else
    MessageBox.Show("Es muss eine IDW offen sein um den Code zu verwenden!", "File Type Mismatch!")
    
End If

[Owner2229 · Accepted solution]

Here you go:

Dim oDoc As Document = ThisApplication.ActiveDocument

If Not oDoc.DocumentType = 12292 Then
    MessageBox.Show("Es muss eine IDW offen sein um den Code zu verwenden!", "File Type Mismatch!")
    Exit Sub
End If

' Look For the model referenced within the drawing. End the Rule If the drawing Is empty.
If ThisDoc.ModelDocument Is Nothing Then
    MessageBox.Show("Diese Option ist in einer leeren Zeichnung unzulässig", "Export error")
    Exit Sub
End If

' Get the style
Dim oStyle As Style
For Each aStyle As Style In oDoc.StylesManager.PartsListStyles
    If aStyle.Name = "KV-Stueli_Deutsch" Then
        oStyle = aStyle
        Exit For
    End If
Next

' End the Rule if the Style doesn't exist
If oStyle Is Nothing Then Exit Sub

' Go throught every sheet.
Dim oSheet As Sheet
For Each oSheet In oDoc.Sheets
    oSheet.TitleBlock.Delete
    oSheet.AddTitleBlock("ET-Liste Deutsch")
    ' Look for partlist within the sheet.
    If oSheet.PartsLists.Count = 0 Then Continue For
    If oSheet.PartsLists(1) IsNot Nothing Then
        ' Set parts list to a specific style
        oSheet.PartsLists(1).Style = oStyle
        ' Change the Layers
        Dim oLayers As LayersEnumerator = oSheet.Parent.StylesManager.Layers
        oLayers.Item("KV deutsch"​).Visible= True
        oLayers.Item("KV englisch"​).Visible= False
    End If
Next

[martinhoos]

Hi Mike,

thank you very much.... !

Regards

Martin

[martinhoos]

I gamble the language with the code, so far it looks great, but there is just a little problem. If i have two sheets in my IDW with text in and i call the code, the layer "kv englisch" will switched off and the layer "kv deutsch" will switched on - the first sheet will be ok. But the second sheet changed not correct, the old layer is visible...

Hope there is a solution to solve that problem.  😉

Thank you very much....

Regards

Martin

Dim oDoc As Document = ThisApplication.ActiveDocument

If Not oDoc.DocumentType = 12292 Then
    MessageBox.Show("Es muss eine IDW offen sein um den Code zu verwenden!", "File Type Mismatch!")
    Exit Sub
End If

' Look For the model referenced within the drawing. End the Rule If the drawing Is empty.
If ThisDoc.ModelDocument Is Nothing Then
    MessageBox.Show("Diese Option ist in einer leeren Zeichnung unzulässig", "Export error")
    Exit Sub
End If

' Get the style
Dim oStyle As Style
For Each aStyle As Style In oDoc.StylesManager.PartsListStyles
    If aStyle.Name = "KV-Stueli_Deutsch" Then
        oStyle = aStyle
        Exit For
    End If
Next

' End the Rule if the Style doesn't exist
If oStyle Is Nothing Then Exit Sub

' Go throught every sheet.
Dim oSheet As Sheet
For Each oSheet In oDoc.Sheets
    oSheet.TitleBlock.Delete
    oSheet.AddTitleBlock("ET-Liste Deutsch")
    ' Look for partlist within the sheet.
If oSheet.PartsLists.Count = 0 Then Continue For
    If oSheet.PartsLists(1) IsNot Nothing Then
        ' Set parts list to a specific style
        oSheet.PartsLists(1).Style = oStyle
        ' Change the Layers
        Dim oLayers As LayersEnumerator = oSheet.Parent.StylesManager.Layers
        oLayers.Item("KV deutsch"​).Visible= True
        oLayers.Item("KV englisch"​).Visible= False
        ThisApplication.ActiveView.Update()
    End If
Next