---

Hallo zusammen,
ich habe ein Makro welches den Schriftkopf in einer Zeichnung bearbeitet.
Das Makro bearbeitet eine ganze Liste von IDWs.
Das klappt solange wie es soll bis das Makro auf eine IDW stößt, die keinen Schriftkopf hat. Da schlägt dann der Set Befehl fehl.
Jetzt meine Frage:
Wie kann ich den prüfen ob die Zeichnung, bzw. exakter das Blatt(1), einen Schriftkopf hat?

Wie gesagt, ansonsten funktioniert das Makro ganz gut, daher hier nur ein Auszug des Quellcodes:

  Dim oapp As Application
    Dim oDoc As DrawingDocument
    Dim oSheet As Sheet
    Dim oTitle As Inventor.TitleBlock
    Dim sData As String
    Dim oTextBox As TextBox
    Dim oTextBoxes As TextBoxes
    Dim props As PropertySets
    Dim customProp As PropertySet
    Dim myProp As Property

    Set oapp = ThisApplication
    oapp.SilentOperation = True
    'Set oDoc = oApp.ActiveDocument
    Set oDoc = oapp.Documents.Open(filename)
    'Set oSheet = oDoc.ActiveSheet
    Set osheer = oDoc.Sheets(1).Name
    Set oTitle = oDoc.ActiveSheet.TitleBlock
   
   
    Set oTextBoxes = oTitle.Definition.Sketch.TextBoxes

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Dann prüfe ob TitleBlock vorhanden ist:

Code:

---

If oSheet.TitleBlock Is Nothing Then
    MsgBox "kein Schriftfeld"
    Exit Sub
End If

---

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

SUPER! Danke...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo zusammen

Ich hoffe, jemand kann mir weiterhelfen.
ich müsste den Namen des Schriftkopfes prüfen, bekomme aber nur eine Fehlermeldung.

Da wir übernomen wurden, sind alle Firmenbenennungen geändert worden. Auch der Name des Zeichnungskopfes in der Zeichnung. Nun Funktioniert das Makro zum Aktualisieren des Zeichnungskopfes nicht mehr. Den alten Zeichnungskopf umbenennen auf den neuen Firmennamen klapp. Wenn ich nun aber eine Zeichnung habe, wo ich nur den Zeichnungskopf aktualisieren muss und bereits den richtigen Namen habe, bekomme ich einen Fehler, da der Umzubenennende Zeichnungskopf nicht gefunden wird. Der Zeichnungsrahmen und die Symbole werden auch ersetzt. Dies funktioniert ohne Probleme.

Ich möchte folgendes Machen. Alter Zeichnungskopf vorhanden, ja/nein.
Wenn ja umbenennen und dann aktualisieren.
Wenn nein, nur aktualisieren.

Ich hatte nie eine Ausbildung auf dem Gebiet und bin mit meinem Kleinstwissen ziemlich am Ende...

Hier ist mein zusammenkopierter Code... (wenn er funktioniert, muss ich dann noch die Codeleichen bereinigen)

----------------------
Sub Zeichnungsressourcen()

'ersetzt die Zeichnungsresourben in der aktuellen Zeichnung durch die der Template

Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
If oDrawDoc.TitleBlockDefinitions.Item("SFA") Is Nothing Then
    MsgBox "goto sfa"
    GoTo SFA
Else
    MsgBox "goto andritz"
    GoTo ANDRITZ

End If

Exit Sub

SFA: '******************************************************** SFA Kopf noch nicht umbenannt

MsgBox "SFA ist da"
  '  If ThisApplication.ActiveDocumentType = kDrawingDocumentObject Then
  Dim ZielDoc As DrawingDocument
  Set ZielDoc = ThisApplication.ActiveDocument
  Dim Blatt As Sheet
  Set Blatt = ZielDoc.ActiveSheet
  Dim i, j As Integer
  Dim zahl1 As Long
  Dim zahl2 As Long

'  If SFA_Test = "" Then
'  MsgBox "kein SFA"
'  Else
'  MsgBox "SFA ist da"
'  End If
 
 
'On Error GoTo ErrorSFA
'        Dim oTitleBlockDef As TitleBlockDefinition
'        Set oTitleBlockDef = oDrawDoc.TitleBlockDefinitions.Item("SFA")

'vorhandenen Blattformate aus activer Zeichnungsresource löschen
  zahl1 = ZielDoc.SheetFormats.Count
  For i = 1 To zahl1
'  On Error Resume Next
  ZielDoc.SheetFormats.Item(zahl1 + 1 - i).Delete
  Next

 
' If oDrawDoc.TitleBlockDefinitions.Item("SFA") = Error Then
'   MsgBox "DKein SFA Zeichnungskopf"
         
        Set oDrawDoc = ThisApplication.ActiveDocument

'        Dim oTitleBlockDef As TitleBlockDefinition
        Set oTitleBlockDef = oDrawDoc.TitleBlockDefinitions.Item("SFA")

        MsgBox oTitleBlockDef.Name

        oTitleBlockDef.Name = "ANDRITZ"

        MsgBox oTitleBlockDef.Name
'    Else
'  End If
 
'    If oSheet.TitleBlock.Item("SFA A4") Is Nothing Then
 
        Set oDrawDoc = ThisApplication.ActiveDocument

'        Dim oTitleBlockDef As TitleBlockDefinition
        Set oTitleBlockDef = oDrawDoc.TitleBlockDefinitions.Item("SFA A4")

        MsgBox oTitleBlockDef.Name

        oTitleBlockDef.Name = "ANDRITZ A4"

        MsgBox oTitleBlockDef.Name
'            Else
' End If

'vorhandene skizzierte Symbole löschen
  On Error Resume Next
  Blatt.SketchedSymbolDefinition.Delete
  zahl1 = ZielDoc.SketchedSymbolDefinitions.Count
  For i = 1 To zahl1
  ZielDoc.SketchedSymbolDefinitions.Item(zahl1 + 1 - i).Delete
  Next

'Resourcen der Template defenieren und Kopieren
  Dim oSketchedSymbolDef As SketchedSymbolDefinition
  Dim QuellDoc As DrawingDocument
  Set QuellDoc = ThisApplication.Documents.Open("P:\Inventor\00003 - Templates\Inventor SFA 2019\A0-1Q-e.idw")

  Dim QuellRahmenA0 As BorderDefinition
  Set QuellRahmenA0 = QuellDoc.BorderDefinitions.Item("A0")
  Dim ZielRahmenA0 As BorderDefinition
  Set ZielRahmenA0 = QuellRahmenA0.CopyTo(ZielDoc, True)

  Dim QuellRahmenA1 As BorderDefinition
  Set QuellRahmenA1 = QuellDoc.BorderDefinitions.Item("A1")
  Dim ZielRahmenA1 As BorderDefinition
  Set ZielRahmenA1 = QuellRahmenA1.CopyTo(ZielDoc, True)

  Dim QuellRahmenA2 As BorderDefinition
  Set QuellRahmenA2 = QuellDoc.BorderDefinitions.Item("A2")
  Dim ZielRahmenA2 As BorderDefinition
  Set ZielRahmenA2 = QuellRahmenA2.CopyTo(ZielDoc, True)

  Dim QuellRahmenA3 As BorderDefinition
  Set QuellRahmenA3 = QuellDoc.BorderDefinitions.Item("A3")
  Dim ZielRahmenA3 As BorderDefinition
  Set ZielRahmenA3 = QuellRahmenA3.CopyTo(ZielDoc, True)

  Dim QuellRahmenA4 As BorderDefinition
  Set QuellRahmenA4 = QuellDoc.BorderDefinitions.Item("A4")
  Dim ZielRahmenA4 As BorderDefinition
  Set ZielRahmenA4 = QuellRahmenA4.CopyTo(ZielDoc, True)

 
'  Dim QuellSchriftfeld_quer As TitleBlockDefinition
  Set QuellSchriftfeld_quer = QuellDoc.TitleBlockDefinitions.Item("ANDRITZ")
'  Dim ZielSchriftfeld_quer As TitleBlockDefinition
  Set ZielSchriftfeld_quer = QuellSchriftfeld_quer.CopyTo(ZielDoc, True)

  Dim QuellSchriftfeld_hoch As TitleBlockDefinition
  Set QuellSchriftfeld_hoch = QuellDoc.TitleBlockDefinitions.Item("ANDRITZ A4")
  Dim ZielSchriftfeld_hoch As TitleBlockDefinition
  Set ZielSchriftfeld_hoch = QuellSchriftfeld_hoch.CopyTo(ZielDoc, True)

'fügt neue skizzierte Symbole aus Template in die Zeichnungsresourcen des activen Blattes ein
  zahl1 = QuellDoc.SketchedSymbolDefinitions.Count
  For i = 1 To zahl1
  Set oSketchedSymbolDef = QuellDoc.SketchedSymbolDefinitions.Item(i).CopyTo(ZielDoc, True)
  Next
  QuellDoc.Close

'schaltet Browserleiste wieder ein
  ThisApplication.UserInterfaceManager.ShowBrowser = True
'  Else: MsgBox ("Ein Schriftfeld kann nur in eine Zeichnung eingefügt werden!")
' End If
 
  Exit Sub
 
 
 
ANDRITZ: '******************************************************** SFA Kopf bereits umbenannt

MsgBox "kein SFA"

  '  If ThisApplication.ActiveDocumentType = kDrawingDocumentObject Then
'  Dim ZielDoc As DrawingDocument
  Set ZielDoc = ThisApplication.ActiveDocument
'  Dim Blatt As Sheet
  Set Blatt = ZielDoc.ActiveSheet
'  Dim i, j As Integer
'  Dim zahl1 As Long

'vorhandenen Blattformate aus activer Zeichnungsresource löschen
  zahl1 = ZielDoc.SheetFormats.Count
  For i = 1 To zahl1
  On Error Resume Next
  ZielDoc.SheetFormats.Item(zahl1 + 1 - i).Delete
  Next

'vorhandene skizzierte Symbole löschen
  On Error Resume Next
  Blatt.SketchedSymbolDefinition.Delete
  zahl1 = ZielDoc.SketchedSymbolDefinitions.Count
  For i = 1 To zahl1
  ZielDoc.SketchedSymbolDefinitions.Item(zahl1 + 1 - i).Delete
  Next

'Resourcen der Template defenieren und Kopieren
'  Dim oSketchedSymbolDef As SketchedSymbolDefinition
'  Dim QuellDoc As DrawingDocument
  Set QuellDoc = ThisApplication.Documents.Open("P:\Inventor\00003 - Templates\Inventor SFA 2019\A0-1Q-e.idw")

'  Dim QuellRahmenA0 As BorderDefinition
  Set QuellRahmenA0 = QuellDoc.BorderDefinitions.Item("A0")
'  Dim ZielRahmenA0 As BorderDefinition
  Set ZielRahmenA0 = QuellRahmenA0.CopyTo(ZielDoc, True)

'  Dim QuellRahmenA1 As BorderDefinition
  Set QuellRahmenA1 = QuellDoc.BorderDefinitions.Item("A1")
'  Dim ZielRahmenA1 As BorderDefinition
  Set ZielRahmenA1 = QuellRahmenA1.CopyTo(ZielDoc, True)

'  Dim QuellRahmenA2 As BorderDefinition
  Set QuellRahmenA2 = QuellDoc.BorderDefinitions.Item("A2")
'  Dim ZielRahmenA2 As BorderDefinition
  Set ZielRahmenA2 = QuellRahmenA2.CopyTo(ZielDoc, True)

'  Dim QuellRahmenA3 As BorderDefinition
  Set QuellRahmenA3 = QuellDoc.BorderDefinitions.Item("A3")
'  Dim ZielRahmenA3 As BorderDefinition
  Set ZielRahmenA3 = QuellRahmenA3.CopyTo(ZielDoc, True)

'  Dim QuellRahmenA4 As BorderDefinition
  Set QuellRahmenA4 = QuellDoc.BorderDefinitions.Item("A4")
'  Dim ZielRahmenA4 As BorderDefinition
  Set ZielRahmenA4 = QuellRahmenA4.CopyTo(ZielDoc, True)
     

'  Dim QuellSchriftfeld_quer As TitleBlockDefinition
'  Set QuellSchriftfeld_quer = QuellDoc.TitleBlockDefinitions.Item("SFA")
'  Dim ZielSchriftfeld_quer As TitleBlockDefinition
'  Set ZielSchriftfeld_quer = QuellSchriftfeld_quer.CopyTo(ZielDoc, True)
 
'  Dim QuellSchriftfeld_quer As TitleBlockDefinition
  Set QuellSchriftfeld_quer = QuellDoc.TitleBlockDefinitions.Item("ANDRITZ")
'  Dim ZielSchriftfeld_quer As TitleBlockDefinition
  Set ZielSchriftfeld_quer = QuellSchriftfeld_quer.CopyTo(ZielDoc, True)

'  Dim QuellSchriftfeld_hoch As TitleBlockDefinition
  Set QuellSchriftfeld_hoch = QuellDoc.TitleBlockDefinitions.Item("ANDRITZ A4")
'  Dim ZielSchriftfeld_hoch As TitleBlockDefinition
  Set ZielSchriftfeld_hoch = QuellSchriftfeld_hoch.CopyTo(ZielDoc, True)

'fügt neue skizzierte Symbole aus Template in die Zeichnungsresourcen des activen Blattes ein
  zahl1 = QuellDoc.SketchedSymbolDefinitions.Count
  For i = 1 To zahl1
  Set oSketchedSymbolDef = QuellDoc.SketchedSymbolDefinitions.Item(i).CopyTo(ZielDoc, True)
  Next
  QuellDoc.Close

'schaltet Browserleiste wieder ein
  ThisApplication.UserInterfaceManager.ShowBrowser = True
'  Else: MsgBox ("Ein Schriftfeld kann nur in eine Zeichnung eingefügt werden!")
'  End If
 

Exit Sub

End Sub

----------------------

MfG
Stephan

[Diese Nachricht wurde von stephan.lehmann am 16. Apr. 2024 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Oder einfacher gefragt, wie kann ich den Namen eines Zeichnungskopfes auslesen und dies vergleichen?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin

Ich würde in TitleBlock.Definition.Name nachsehen.

Code:

---

If TitleBlock.Definition.Name = "SFA" Then

---

Den Code kann ich mir ggf. später ansehen.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin

Etwas eingedampft. aber sollte alles wie geplant erledigen.

Code:

---

Option Explicit

Sub Zeichnungsressourcen()

'ersetzt die Zeichnungsressourcen in der aktuellen Zeichnung durch die des Templates

If Not ThisApplication.ActiveDocumentType = kDrawingDocumentObject Then
    Call MsgBox("Funktion nur in Zeichnungen zulässig.", vbCritical, "Zeichnungsressourcen aktualisieren")
    Exit Sub
End If
   
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument

' Schriftfelddefinition ggf. umbenennen
Dim oTitleBlockDef As TitleBlockDefinition
For Each oTitleBlockDef In oDrawDoc.TitleBlockDefinitions
    If oTitleBlockDef.Name = "SFA" Then
        oTitleBlockDef.Name = "ANDRITZ"
    ElseIf oTitleBlockDef.Name = "SFA A4" Then
        oTitleBlockDef.Name = "ANDRITZ A4"
    End If
Next

'vorhandenen Blattformate aus aktiver Zeichnungsressource löschen
Dim oSheetFormat As SheetFormat
For Each oSheetFormat In oDrawDoc.SheetFormats
  Call oSheetFormat.Delete
Next

Dim oSheet As Sheet
Dim oActiveSheet As Sheet
Dim oSketchedSymbol As SketchedSymbol
Dim oSketchedSymbolDef As SketchedSymbolDefinition

' Merken des aktuell aktiven Blattes
Set oActiveSheet = oDrawDoc.ActiveSheet

'Durchlauf durch alle Blätter
For Each oSheet In oDrawDoc.Sheets
    'Blatt aktivieren, da das Löschen sonst eventuell fehlschlägt (kann man testweise weglassen)
    Call oSheet.Activate
    ' Löschen aller skizzierten Symbole
    For Each oSketchedSymbol In oSheet.SketchedSymbols
        Call oSketchedSymbol.Delete
    Next
Next

' Aktivieren des ursprünglich aktiven Blattes
Call oActiveSheet.Activate

' Löschen aller Symboldefinitionen
' Symboldefinitionen lassen sich nur löschen, wenn keine Referenz darauf mehr existiert
For Each oSketchedSymbolDef In oDrawDoc.SketchedSymbolDefinitions
    If oSketchedSymbolDef.IsReferenced = False Then
        Call oSketchedSymbolDef.Delete
    End If
Next

On Error Resume Next
Dim QuellDoc As DrawingDocument
Set QuellDoc = ThisApplication.Documents.Open("P:\Inventor\00003 - Templates\Inventor SFA 2019\A0-1Q-e.idw")

If Err.Number <> 0 Then
    Call MsgBox("Fehler beim Öffnen der Templatedatei.", vbCritical, "Zeichnungsressourcen aktualisieren")
    Exit Sub
End If

Dim oBorderDef As BorderDefinition
For Each oBorderDef In QuellDoc.BorderDefinitions
    Select Case oBorderDef.Name
        Case "A0", "A1", "A2", "A3", "A4": Call oBorderDef.CopyTo(oDrawDoc, True)
    End Select
Next

For Each oTitleBlockDef In QuellDoc.TitleBlockDefinitions
    Select Case oTitleBlockDef.Name
        Case "ANDRITZ", "ANDRITZ A4": Call oTitleBlockDef.CopyTo(oDrawDoc, True)
    End Select
Next

For Each oSketchedSymbolDef In QuellDoc.SketchedSymbolDefinitions
    Call oSketchedSymbolDef.CopyTo(oDrawDoc, True)
Next

Call QuellDoc.Close

'schaltet Browserleiste wieder ein
  ThisApplication.UserInterfaceManager.ShowBrowser = True

End Sub

---

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin Ralf
Besten Dank erst mal!
Ich habe den Code eingesetzt und getestet.
Die Rahmen werden gewechselt, falls noch alte vorhanden sind. Die Symbole werden auch aktualisiert. Die Zeichnungsköpfe werden umbenannt, aber nicht durch die aktuellen ersetzt. Es ist immer noch das alte Logo im Zeichnungskopf.

Ich versuche gerade, den Code zu Verstehen. Ich kenne ein paar Sachen von Excel VBA her, aber die Befehle für Inventor sind irgendwie andere und ich kenne die wenigsten davon. Man lernt halt nie aus.

Gruss
Stephan

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin

Kleiner Copy'n Paste Fehler. In dem Codeblock:

Code:

---

For Each oTitleBlockDef In QuellDoc.TitleBlockDefinitions
    Select Case oBorderDef.Name
        Case "ANDRITZ", "ANDRITZ A4": Call oTitleBlockDef.CopyTo(oDrawDoc, True)
    End Select
Next

---

muss es natürlich nicht "Select Case oBorderDef.Name", sondern "Select Case oTitleBlockDef.Name" heißen. Ersetz das bitte mal. Ich korrigiere den Code oben entsprechend.

------------------
MfG
Ralf

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin Ralf

PERFEKT! Nun geht es. Vielen Herzlichen Dank!

Grüsse aus der Schweiz
Stephan

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP