Ich habe in meinem letzten Projekt ein kleines VBA Tool geschrieben welches dafür verwendet werden kann, aus einer angegeben Vorlage (Pfad) den Schriftkopf in die aktuelle Zeichnung zu kopieren. Benutzung auf eigene Gefahr Sub Schriftkopf_tauschen()
Dim odrawdoc As DrawingDocument
On Error Resume Next
Set odrawdoc = ThisApplication.ActiveDocument If (odrawdoc.DocumentType <> kDrawingDocumentObject) Then Exit Sub
Dim oTemplate As DrawingDocument
Dim oSourceTitleBlockDef As TitleBlockDefinition
Dim oNewTitleBlockDef As TitleBlockDefinition
Dim oSheet As Sheet
Dim titlename As String
Dim Titelblock As TitleBlock
Set oSheet = odrawdoc.ActiveSheet
Set Titelblock = odrawdoc.ActiveSheet.TitleBlock
If (Titelblock Is Nothing) Then
MsgBox ("Kein Schriftkopf vorhanden")
Exit Sub
ElseIf (Titelblock.Name = "DIN") Then
titlename = "DIN"
Else:
MsgBox ("Kein DIN Schriftkopf vorhanden")
Exit Sub
End If
Set oTemplate = ThisApplication.Documents.Open("C:PROTOTYPENNorm.idw", False)
Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc, True)
' Iterate through the sheets.
For Each oSheet In odrawdoc.Sheets
'oSheet.Activate if error occurs
oSheet.TitleBlock.Delete
Call oSheet.AddTitleBlock(oNewTitleBlockDef)
Next
oTemplate.Close
Exit Sub End Sub Zwei Zeilen müssen auf die aktuelle Umgebung angebpasst werden: 1) Pfad an der die Prototypen Datei vorhanden ist Set oTemplate = ThisApplication.Documents.Open("C:TempPROTOTYPENnorm.idw", False)
2) Name des Schriftkopfes ElseIf (Titelblock.Name = "DIN") Then
titlename = "DIN"
Dim odrawdoc As DrawingDocument
On Error Resume Next
Set odrawdoc = ThisApplication.ActiveDocument If (odrawdoc.DocumentType <> kDrawingDocumentObject) Then Exit Sub
Dim oTemplate As DrawingDocument
Dim oSourceTitleBlockDef As TitleBlockDefinition
Dim oNewTitleBlockDef As TitleBlockDefinition
Dim oSheet As Sheet
Dim titlename As String
Dim Titelblock As TitleBlock
Set oSheet = odrawdoc.ActiveSheet
Set Titelblock = odrawdoc.ActiveSheet.TitleBlock
If (Titelblock Is Nothing) Then
MsgBox ("Kein Schriftkopf vorhanden")
Exit Sub
ElseIf (Titelblock.Name = "DIN") Then
titlename = "DIN"
Else:
MsgBox ("Kein DIN Schriftkopf vorhanden")
Exit Sub
End If
Set oTemplate = ThisApplication.Documents.Open("C:PROTOTYPENNorm.idw", False)
Set oSourceTitleBlockDef = oTemplate.ActiveSheet.TitleBlock.Definition
Set oNewTitleBlockDef = oSourceTitleBlockDef.CopyTo(odrawdoc, True)
' Iterate through the sheets.
For Each oSheet In odrawdoc.Sheets
'oSheet.Activate if error occurs
oSheet.TitleBlock.Delete
Call oSheet.AddTitleBlock(oNewTitleBlockDef)
Next
oTemplate.Close
Exit Sub End Sub Zwei Zeilen müssen auf die aktuelle Umgebung angebpasst werden: 1) Pfad an der die Prototypen Datei vorhanden ist Set oTemplate = ThisApplication.Documents.Open("C:TempPROTOTYPENnorm.idw", False)
2) Name des Schriftkopfes ElseIf (Titelblock.Name = "DIN") Then
titlename = "DIN"
