Attribute VB_Name = "Modul1"
Public Sub Schriftfeld_ersetzen()

    If ThisApplication.Documents.Count = 0 Then
        MsgBox "No Document open", 16, "Error"
        Exit Sub
    Exit Sub
    End If
    
    If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
        MsgBox "No Drawing", 16, "Error"
        Exit Sub
    End If

    Dim oApp As Application
    Set oApp = ThisApplication


    
    Dim i As Long
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    On Error Resume Next
    For i = oDrawDoc.TitleBlockDefinitions.Count To 1 Step -1
           
        oDrawDoc.TitleBlockDefinitions.Item(i).delete
   
    Next i
    
    Dim oNewDocument As DrawingDocument
    Set oNewDocument = ThisApplication.ActiveDocument
    
    Dim oSourceDocument As DrawingDocument
    Set oSourceDocument = ThisApplication.Documents.Open(ThisApplication.FileLocations.FileLocationsFilesDir & "\norm.idw", False)
    

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

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

    ' Iterate through the sheets.
    Dim oSheet As Sheet
    For Each oSheet In oNewDocument.Sheets
        oSheet.Activate
        oSheet.TitleBlock.delete
        Call oSheet.AddTitleBlock(oNewTitleBlockDef)
    Next
    oSourceDocument.Close SaveChanges = False
    
    
    
    
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    On Error Resume Next
    For i = oDrawDoc.TitleBlockDefinitions.Count To 1 Step -1
           
        oDrawDoc.TitleBlockDefinitions.Item(i).delete
   
    Next i
       
    For i = oDrawDoc.BorderDefinitions.Count To 1 Step -1
   
        oDrawDoc.BorderDefinitions.Item(i).delete
   
    Next i
    
    For i = oDrawDoc.SketchedSymbolDefinitions.Count To 1 Step -1
   
        oDrawDoc.SketchedSymbolDefinitions.Item(i).delete
   
    Next i
    
    
    On Error GoTo 0

    Set oDrawDoc = Nothing
   


End Sub