---

Hallo Forumuser,

hab folgenden Text in der Inventor API Hilfe gefunden!

Public Sub TitleBlockCopy()

    Dim oSourceDocument As DrawingDocument
    Set oSourceDocument = ThisApplication.ActiveDocument

    ' Open the new drawing to copy the title block into.
    Dim oNewDocument As DrawingDocument
    Set oNewDocument = ThisApplication.Documents.Open("C:\temp\TitleBlockChange.idw")

    ' 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
End Sub

mit diesem Code wird von der aktuell offenen idw das Schriftfeld kopiert und in ein anderes eingefügt!

Ich brauche das ganze allerdings andersrum!

Und zwar soll von einer Quelldatei das Schriftfeld kopiert werden und in die aktuell offene idw eingefügt werden!

kann mir jemand erklären wie das geht?

MfG
freak

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

---

Hi,

auf die schnelle und ohne es Probiert zu haben würde ich sagen du kasst die Zeile

Set oSourceDocument = ThisApplication.ActiveDocument
durch
Set oSourceDocument = ThisApplication.Documents.Open("C:\temp\<QUELL.IDW aus welcher das sfeld kopiert werden soll>")

austauschen und dann die beiden Zeilen :
    Dim oNewDocument As DrawingDocument
    Set oNewDocument = ThisApplication.Documents.Open("C:\temp\TitleBlockChange.idw")
ebenfalls austauschen und vor ! der Zeile Set = oSourceDocument einfügen
    Dim oNewDocument As DrawingDocument
    Set oNewDocument = ThisApplication.ActiveDocument

Gruß
Micha

------------------
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht…

Zitat:

---

Interpunktion und Orthographie des Postings sind frei erfunden.
Eine Übereinstimmung mit aktuellen oder ehemaligen Regeln wäre rein zufällig und ist nicht beabsichtigt.

---

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

---

Danke es hat geklappt!

kannst du mir noch sagen wie ich im aktuellen Dokument das Schriftfeld lösche?

MfG
Thomas

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

---

inetwa so:

Code:

---

 
' Check to see if the sheet already has a title block and delete it if it does.
    If Not oSheet.TitleBlock Is Nothing Then
        oSheet.TitleBlock.Delete
    End If

---

und dann überflüssige Definitionen löscht man so:

Code:

---

Public Sub RemoveUnusedTitleBlocksDefinitionsFromDoc()

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim i As Long
   
    For i = oDrawDoc.TitleBlockDefinitions.Count To 1 Step -1
        If Not oDrawDoc.TitleBlockDefinitions.Item(i).IsReferenced Then
            oDrawDoc.TitleBlockDefinitions.Item(i).Delete
        End If
    Next i
   
    Set oDrawDoc = Nothing
   
End Sub

---

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Danke funzt richtig gut!

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

---

Zitat:

---

Original erstellt von freak-tom:
Danke funzt richtig gut!

---

Danke für die U's  .

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Zitat:

---

Original erstellt von lbcad:
Danke für die U's   .

---

auch von mir 

------------------
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht…

Zitat:

---

Interpunktion und Orthographie des Postings sind frei erfunden.
Eine Übereinstimmung mit aktuellen oder ehemaligen Regeln wäre rein zufällig und ist nicht beabsichtigt.

---

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

---

Zitat:

---

Original erstellt von VBSpawn:
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht

---

ich würde sagen:

"Manche Menschen gehen so plötzlich, daß die Zeit für U's nicht reicht."

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Na,

hast doch welche bekommen <g>
aber so ist das mit den 'Jungen Dingern' immerhin kam eine Rückmeldung ist doch auch schon viel Wert..

Gruß
Micha

------------------
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht…

Zitat:

---

Interpunktion und Orthographie des Postings sind frei erfunden.
Eine Übereinstimmung mit aktuellen oder ehemaligen Regeln wäre rein zufällig und ist nicht beabsichtigt.

---

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

---

Hi Micha,

von Dir ja - aber Du standest ja auf der Helferseite   

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Hallo Leute

was sind Uus?

MfG
Freak

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

---

UUS.GIF

Zitat:

---

Original erstellt von freak-tom:
...was sind Uus?...

---

sieh mal hier : -->

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Zitat:

---

Original erstellt von freak-tom:
was sind Uus?

---

... für die frage gibt's 10 U's von mir...     

------------------
Grüsse, Paul

Inventor-Programmierung, Inventor-Tools und Inventor API-Schulung

thinkCAD Web-Kataloge

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

---

Zitat:

---

Original erstellt von PaulSchuepbach:
... für die frage gibt's 10 U's von mir...          

---

von mir auch!!!!    

------------------
Gruß
SEHER
www.inventor-tools.de

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

---

Auf jeden Fall klappt das jetzt ( mit Anleitung ). 

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Bei mir nicht  <schnief>

------------------
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht…

Zitat:

---

Interpunktion und Orthographie des Postings sind frei erfunden.
Eine Übereinstimmung mit aktuellen oder ehemaligen Regeln wäre rein zufällig und ist nicht beabsichtigt.

---

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

---

Zitat:

---

Original erstellt von VBSpawn:
Bei mir nicht  <schnief>

---

Dann kriegste halt welche von mir  .

------------------
Gruß Lothar

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

Während man es aufschiebt, verrinnt das Leben.
Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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

---

Zitat:

---

Original erstellt von lbcad:
Dann kriegste halt welche von mir   .

---

danke, danke und das jammern hat gewirkt.

Gruß
Micha

------------------
Manche Menschen gehen so plötzlich, daß die Zeit für einen Abschied nicht reicht…

Zitat:

---

Interpunktion und Orthographie des Postings sind frei erfunden.
Eine Übereinstimmung mit aktuellen oder ehemaligen Regeln wäre rein zufällig und ist nicht beabsichtigt.

---

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

---

Zitat:

---

Original erstellt von VBSpawn:
danke, danke und das jammern hat gewirkt.

---

Gut gejammert ist das halbe Geschäft...

Also Ihr Heulsusen: 10 für SEHER, 10 für Micha und 10 für Lothar.

------------------
Grüsse, Paul

Inventor-Programmierung, Inventor-Tools und Inventor API-Schulung

thinkCAD Web-Kataloge

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

---

Ich mach da irgendwas falsch. Habe die Zeilen gemäss angaben ersetzt, aber er bringt mir immer wieder einen Laufzeitfehler, dieser heisst nicht immer gleich. Der neuste ist XML document must have a top level element.

Hier mein Code:

Public Sub TitleBlockCopy()

    Dim oNewDocument As DrawingDocument
    Dim oSourceDocument As DrawingDocument
    Set oNewDocument = ThisApplication.ActiveDocument
    Set oSourceDocument = ThisApplication.Documents.Open("O:\SYSTEM\Inventor_SYS\Templates\Zeichnung A4.idw")

    ' 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
End Sub

Danke vielmals

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

---

Hallo Muelb,

versuchs mal ohne Leerzeichen in deinem Dateinamen!

MfG
Thomas

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

---

Hallo Muelb,

vielleicht als Hilfe mein fertiges Macro, das funktioniert!

Code:

---

Public Sub Schriftfeld_ersetzen()
    'MsgBox Environ$("Inventor")
    If ThisApplication.ActiveDocument Is Nothing Then
        MsgBox "No Document open", 16, "Error"
        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(Environ$("Inventor") & "\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.SketchedSymbolDefinitions.Count To 1 Step -1
 
        oDrawDoc.SketchedSymbolDefinitions.Item(i).Delete
 
    Next i
   
   
    On Error GoTo 0

    Set oDrawDoc = Nothing
 
End Sub

---

Der Code macht folgendes:

1. Er schaut ist überhaupt ein Dokument im Inventor geöffnet
2. Wenn ja prüft er ob es eine Zeichnung ist
3. Er löscht alle Schriftfelder, die nicht verwendet werden aus der Zeichnung raus
4. ThisApplication.Documents.Open(Environ$("Inventor") & "\norm.idw" hiermit fragt er die Variable Inventor ab, in der der Pfad steht und hängt norm.idw dran in der Norm.idw ist mein neues Schriftfeld!
5. Er kopiert das angezeigte Schriftfeld aus der Norm.idw heraus und fügt es in die geöffnete Datei ein.
6. Er schließt die Norm.idw ohne diese zu speichern
7. Er löscht erneut alle nicht verwendeten Schriftfelder
8. Er löscht alle nicht verwendeten skizierten Symbole

und ist damit fertig! :-)

MfG
Thomas

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

---

Danke für den Code, hab ihn gleich getestet. Leider funktioniert bei mir der Austausch noch nicht, er löscht zwar den alten Zeichnungskopf, aber kann den neuen nicht einfügen (ohne Fehlermeldung).

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

---

Hallo Muelb,

hast du den Code 1 zu 1 eingefügt? oder hast du was geändert?

MfG
Thomas

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

---

Ich hatte das Makro ein wenig auf "die lange Bank" geschoben. Nun hab ich den Fehler gefunden. Wenn beim Einfügen des Schriftkopfes Eingaben angefordert werden muss man diese im Makro gleich mitgeben (Dim sPromptStrings(1 To 20) As String), sonst passiert einfach nichts.

Public Sub Schriftfeld_ersetzen()
    'MsgBox Environ$("Inventor")
    If ThisApplication.ActiveDocument Is Nothing Then
        MsgBox "No Document open", 16, "Error"
        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("C:\Zeichnung_zur_uebernahme_Schriftkopf.idw", False)
 
    Dim iZahl As Integer
    For iZahl = oSourceDocument.TitleBlockDefinitions.Count To 1 Step -1
        Set oTitleDef = oSourceDocument.TitleBlockDefinitions.Item(iZahl)
        Call oTitleDef.CopyTo(oNewDocument, True)
    Next iZahl

   
   
    ' 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)
   
    ' This title block definition contains one prompted string input. An array
    ' must be input that contains the strings for the prompted strings.
    Dim sPromptStrings(1 To 20) As String
    sPromptStrings(1) = "String 1"
    sPromptStrings(2) = "String 2"
    sPromptStrings(3) = "String 3"
    sPromptStrings(4) = "String 4"
    sPromptStrings(5) = "String 5"
    sPromptStrings(6) = "String 6"
    sPromptStrings(7) = "String 7"
    sPromptStrings(8) = "String 8"
    sPromptStrings(9) = "String 9"
    sPromptStrings(10) = "String 10"
    sPromptStrings(11) = "String 11"
    sPromptStrings(12) = "String 12"
    sPromptStrings(13) = "String 13"
    sPromptStrings(14) = "String 14"
    sPromptStrings(15) = "String 15"
    sPromptStrings(16) = "String 16"
    sPromptStrings(17) = "String 17"
    sPromptStrings(18) = "String 18"
    sPromptStrings(19) = "String 19"
    sPromptStrings(20) = "String 20"
   
   
    ' Iterate through the sheets.
    Dim oSheet As Sheet
    For Each oSheet In oNewDocument.Sheets
        oSheet.Activate
        oSheet.TitleBlock.Delete
        Call oSheet.AddTitleBlock(oNewTitleBlockDef, , sPromptStrings)
    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.SketchedSymbolDefinitions.Count To 1 Step -1
 
        oDrawDoc.SketchedSymbolDefinitions.Item(i).Delete
 
    Next i
   
   
    On Error GoTo 0

    Set oDrawDoc = Nothing
 
End Sub

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

---

Hallo muelb,

wenn du natürlich angeforderte Eingaben in deinem Schriftfeld hast dann ist das so!
Ich habe keine Anforderungen drin, deshalb funzt es bei mir!

MfG
Frek-tom

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