---

Liebe Gemeinde, ich habe auf einem Rechner zwar durch das MUM-Tool dies schon auf einem anderen Rechner nicht 

Kann mir jemand helfen und so einen vba schreiben wo von einen definierten Pfad die der Schriftkopf aus der Norm.idw kopiert wird und in die gerade geöffnete Zeichnung paltziert wird.

herzlichen Dank Sascha

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

---

Ich kann es dir nicht schreiben, aber diesen Codeschnipsel geben:

Code:

---

        'Zeichnung akt
        Sub zeichnungsResourcen_akt() ' aktualisieren (aus vorlage übernehmen)

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

            Dim Blatt As Sheet
            Blatt = oDocD.ActiveSheet
            Dim i, j As Integer
            Dim zahl1 As Long
            Dim zahl2 As Long

            'vorhandenes Schriftfeld und Rahmen aus aktiver Zeichnung löschen (Step#2)
            'On Error Resume Next
            Dim osheet As Sheet
            For Each osheet In oDocD.Sheets
                osheet.Activate()
                osheet.TitleBlock.Delete()
                osheet.Border.Delete()
            Next

            zahl1 = oDocD.TitleBlockDefinitions.Count
            For i = 1 To zahl1
                On Error Resume Next
                oDocD.TitleBlockDefinitions.Item(zahl1 + 1 - i).Delete()
            Next

            'Resourcen der Template defenieren und Kopieren(Step#5)
            Dim oSketchedSymbolDef As SketchedSymbolDefinition
            Dim arbeitsordner As String
            arbeitsordner = oApp.DesignProjectManager.ActiveDesignProject.WorkspacePath

            Dim QuellDoc As DrawingDocument
            QuellDoc = oApp.Documents.Open(arbeitsordner & "\8 Vorlagen\Norm.idw")

            Dim QuellSchriftfeld As TitleBlockDefinition
            QuellSchriftfeld = QuellDoc.TitleBlockDefinitions.Item("DIN")
            Dim ZielSchriftfeld As TitleBlockDefinition
            ZielSchriftfeld = QuellSchriftfeld.CopyTo(oDocD, True)

            QuellDoc.Close()

            'fügt Zeichnungsrahmen ins Active Blatt ein (Step#7)
            'Call Blatt.AddBorder(ZielRahmen)
            For Each osheet In oDocD.Sheets
                osheet.Activate()
                osheet.AddDefaultBorder(,,,,,, Centermarks:=False, TopMargin:=0.7, BottomMargin:=0.7, LeftMargin:=1.3, RightMargin:=0.7)
            Next

            'fügt neues Schriftfeld in alle Blätter ein(Step#8)
            For Each osheet In oDocD.Sheets
                osheet.Activate()
                osheet.AddTitleBlock(oDocD.TitleBlockDefinitions.Item("DIN"))
            Next

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

        End Sub

---

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

---

Moin

@fons
Dein Script räumt aber alle vorhandenen Schriftköpfe und Rahmen aus der Zeichnung. Das sollte man vielleicht dazu sagen.
Lauffähig ist es so auch nicht, da z.B. die Deklaration von oApp und DocD fehlen.  

@freierfall
Da ich es eh fertig habe, als Alternativvorschlag. Ist iLogic Code.

Code:

---

Option Explicit on

Private Sub Main()
' tauscht Schriftfeld aus

Dim oSource As DrawingDocument
Dim oTrans As Transaction = ThisApplication.TransactionManager.StartTransaction(ThisDoc.Document, "Replace Titleblock")

Try
ThisApplication.ScreenUpdating = False

Dim sSource As String
sSource = "C:\Temp\Source.idw" ' <--- vollständiger Pfad zur Quelldatei
Dim sSourceTitleBlockname As String
sSourceTitleBlockname = "MyNewTitleblock" ' <--- Name der Schriftfelddefinition in der Quelldatei

If Not System.IO.File.Exists(sSource) Then
    Call MsgBox("Konnte Quelldatei '" & sSource & "' nicht finden.", vbCritical, "Replace Titleblock")
    Exit Sub
End If
   
oSource = ThisApplication.Documents.Open(sSource, False)

Dim oSourceTitleBlockDef As TitleBlockDefinition
For Each oSourceTitleBlockDef In oSource.TitleBlockDefinitions
    If oSourceTitleBlockDef.Name = sSourceTitleBlockname Then
        Exit For
    End If
Next

If oSourceTitleBlockDef Is Nothing Then
    MsgBox("Konnte Quellschriftfeld '" & sSourceTitleBlockname & "' nicht finden.", vbCritical, "Replace Titleblock")
    Exit Sub
End If

Dim oDrawDoc As DrawingDocument = ThisDoc.Document
Dim bAllSheets As Boolean=False
If oDrawDoc.Sheets.Count > 1 Then
If MsgBox("In allen Blättern austauschen?", MsgBoxStyle.YesNo, "iLogic Replace Titleblock")=MsgBoxResult.Yes Then bAllSheets=True
End If

Dim oTitleblockDef As TitleBlockDefinition
Dim oNewTitleblockDef As TitleBlockDefinition
For Each oTitleblockDef In oDrawDoc.TitleBlockDefinitions
If oTitleblockDef.Name = sSourceTitleBlockname Then
If MsgBox("Ein Schriftfeld mit gleichem Namen (" & oSourceTitleBlockDef.Name & " existiert bereits. Überschreiben?", MsgBoxStyle.YesNo, "iLogic Replace Titleblock") = MsgBoxResult.Yes Then
oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc, True)
Exit For
Else
oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc, False)
End If
End If
Next

If oNewTitleblockDef Is Nothing Then oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc)

Dim oSheet As Sheet
Dim oActiveSheet As Sheet=oDrawDoc.ActiveSheet
If bAllSheets=True Then
    For Each oSheet In oDrawDoc.Sheets
oSheet.Activate
        oSheet.TitleBlock.Delete
        oSheet.AddTitleBlock (oNewTitleblockDef)
    Next
oActiveSheet.Activate
Else
    If Not oActiveSheet.TitleBlock Is Nothing Then oDrawDoc.ActiveSheet.TitleBlock.Delete
    oActiveSheet.AddTitleBlock(oNewTitleblockDef)
End If

oSource.Close (True)

oTrans.End
Catch ex As Exception
oTrans.Abort
MsgBox(ex.Message,MsgBoxStyle.Critical,"iLogic Replace Titleblock" )
If Not oSource Is Nothing Then oSource.Close(True)
Finally
ThisApplication.ScreenUpdating=True
End Try

End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

wow, es geht super gut. für mich ist das echt nicht verständlich  deswegen bin ich Dir sehr dankbar. sei herzlich gegrüsst Sascha

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

---

Hallo,

genau sowas benötige ich auch!!
Unser Firmenstandart hat sich geändert und wir müssen fast
alle Schriftköpfe austauschen.
Genial das es sowas gibt.
Nun habe ich noch Fragen über Fragen dazu.
Tauscht das NUR den Schriftkopf aus?
Wo muss ich den Quellpfad ändern?
und wie bekomme ich das in eine Ilogic?

Sorry, aber ich kenn mich damit so gut wie gar nicht aus.

MfG Thomas

------------------
==========
MfG
Thomas

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

---

Hallo

@thpg
1. Ja, das tauscht nur den Schriftkopf aus, weil Sascha ja nur den Schriftkopf austauschenn wollte.
2. Den Quellpfad ändert man in einer der obersten Zeilen ( da wo der Kommentar : "vollständiger Pfad zur Quelldatei") steht. Knapp darunter kommt die Zeile in der man den Namen des Schriftfeldes in der Quelldatei eingibt.
3. Das ist iLogic Code. Einfach Copy'n Paste in eine neue externe Regel und ausführen.

@freierfall
Falls du mich gemeint hast, ich mach das ja auch seit 20 Jahren und mittlerweile hauptberuflich. 

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Mahlzeit,

Danke, wer lesen kann ist klar von Vorteil.

Super!!
Es funktioniert!!

------------------
==========
MfG
Thomas

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

---

Nur zur Ergänzung:
Ich verwende bei meinen Schriftköpfen zusätzlich Attribute-Sets. Das hat den Charme, dass ich den verschiedenen Schriftköpfen in der Vorlage Schriftkopfversion, Schriftkopfart (intern, extern), Schriftkopfsprache (de, en) etc. zuweisen bzw. natürlich auch abfragen kann.
Sprich beim Ausführen meiner Funktion wird anhand der Attribute-Sets geprüft, welcher Schriftkopf aktuell vorhanden ist. Dann erfolgt eine Prüfung, ob es eine neuere Version in der Vorlage gibt. Erst wenn dies zutrifft, wird der Schriftkopf mit seinem adäquaten Nachfolger ausgetauscht.

Der Jobserver kennt die aktuellen Versionsstände und gibt nur Zeichnungen mit aktuellen Schriftkopf frei...

Auch für die VBA-Kollegen kann man mittels dem Attribute-Manager direkt mit dem Namen auf ein Attribute zugreifen und muss nicht alle mühsam durchlaufen.  

Generell sind Attribute-Sets eine klasse Sache  
https://modthemachine.typepad.com/my_weblog/2009/07/introduction-to-attributes.html

VG
MB-Ing.

------------------
Wissen ist Macht. Nichts wissen macht auch nichts  

[CS-Edit: Hab DIr mal den Link zurechtgeruckelt ;-) ]

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

---

Hallo,

ich habe leider noch eine Frage dazu.

Wir haben für bestimmte Bauteile einen speziellen Schriftkopf
mit einer angeforderten Eingabe in den iProberties, bei der dann Fertigungsparameter mit eingetragen werden.
Bei diesem Schriftkopf funktioniert die iLogic leider nicht.

Gibt es evtl. dafür auch eine Lösung?

Ich wäre sehr dankbar dafür.

------------------
==========
MfG
Thomas

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

---

Hallo

Für jede angeforderte Eingabe kommt jetzt eine Eingabeaufforderung. Ich hoffe ihr habt nicht 100 davon in eurem Schriftfeld. Bitte beachten, die Abfrage kommt pro angeforderter Eingabe nur einmal und verwendet die Eingaben für alle Blätter, wenn "Schriftfeld in allen Blätter austauschen" gewählt wurde. Sollten unterschiedliche Werte erforderlich sein, entweder die Schriftfelder einzeln ersetzen oder nach dem Ersetzen jedes Blatt nacharbeiten. Man könnte zwar für jedes Blatt die Angaben einzeln abfragen, aber ich denke mit 10 angeforderten Eingabe und 5 Blättern (= 50 angeforderte Eingaben) wird das sehr fehleranfällig.

Code:

---

Option Explicit on

Private Sub Main()
' tauscht Schriftfeld aus

Dim oSource As DrawingDocument
Dim oTrans As Transaction = ThisApplication.TransactionManager.StartTransaction(ThisDoc.Document, "Replace Titleblock")

Try
ThisApplication.ScreenUpdating = False

Dim sSource As String
sSource = "C:\Temp\Source.idw" ' <--- vollständiger Pfad zur Quelldatei
Dim sSourceTitleBlockname As String
sSourceTitleBlockname = "MyNewTitleblock" ' <--- Name der Schriftfelddefinition in der Quelldatei

If Not System.IO.File.Exists(sSource) Then
    Call MsgBox("Konnte Quelldatei '" & sSource & "' nicht finden.", vbCritical, "Replace Titleblock")
    Exit Sub
End If

Dim bOpen As Boolean=False
For Each oDoc As Document In ThisApplication.Documents
If oDoc.FullFileName.ToUpper  = sSource.ToUpper  Then
oSource = TryCast(oDoc,Inventor.DrawingDocument)
oDoc=Nothing
Exit For
End If
Next

If oSource Is Nothing Then
oSource = ThisApplication.Documents.Open(sSource, False)
bOpen = True
End If

Dim oSourceTitleBlockDef As TitleBlockDefinition
For Each oSourceTitleBlockDef In oSource.TitleBlockDefinitions
    If oSourceTitleBlockDef.Name  = sSourceTitleBlockname Then
        Exit For
    End If
Next

If oSourceTitleBlockDef Is Nothing Then
    MsgBox("Konnte Quellschriftfeld '" & sSourceTitleBlockname & "' nicht finden.", vbCritical, "Replace Titleblock")
    Exit Sub
End If

Dim oDrawDoc As DrawingDocument = ThisDoc.Document
Dim bAllSheets As Boolean=False
If oDrawDoc.Sheets.Count > 1 Then
If MsgBox("In allen Blättern austauschen?", MsgBoxStyle.YesNo, "iLogic Replace Titleblock")=MsgBoxResult.Yes Then bAllSheets=True
End If

Dim oTitleblockDef As TitleBlockDefinition
Dim oNewTitleblockDef As TitleBlockDefinition
For Each oTitleblockDef In oDrawDoc.TitleBlockDefinitions
If oTitleblockDef.Name = sSourceTitleBlockname Then
If MsgBox("Ein Schriftfeld mit gleichem Namen (" & oSourceTitleBlockDef.Name & " existiert bereits. Überschreiben?", MsgBoxStyle.YesNo, "iLogic Replace Titleblock") = MsgBoxResult.Yes Then
oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc, True)
Exit For
Else
oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc, False)
End If
End If
Next

If oNewTitleblockDef Is Nothing Then oNewTitleblockDef = oSourceTitleBlockDef.CopyTo(oDrawDoc)

Dim sString As String
Dim sPrompt As String
Dim oTextBox As Inventor.TextBox
For Each oTextBox In oNewTitleblockDef.Sketch.TextBoxes
If oTextBox.FormattedText.StartsWith("<Prompt") Then
sPrompt=InputBox("Angeforderte Eingabe für " & oTextBox.Text & ":","iLogic Replace Titleblock")
If sPrompt=String.Empty Then
sPrompt = " "
End If
If sString = String.Empty Then
sString=sPrompt
Else
sString=sString & vbLf & sPrompt
End If
End If
Next

Dim aStrings() As String = Split(sString,vbLf)

Dim oSheet As Sheet
Dim oActiveSheet As Sheet = oDrawDoc.ActiveSheet
Dim oTitleBlock As TitleBlock
If bAllSheets=True Then
    For Each oSheet In oDrawDoc.Sheets
oSheet.Activate
        If Not oSheet.TitleBlock Is Nothing Then oSheet.TitleBlock.Delete
If UBound(aStrings) >=0 Then
    oTitleBlock=oSheet.AddTitleBlock(oNewTitleblockDef, , aStrings)
Else
oTitleBlock=oSheet.AddTitleBlock(oNewTitleblockDef)
End If
    Next
oActiveSheet.Activate
Else
    If Not oActiveSheet.TitleBlock Is Nothing Then oDrawDoc.ActiveSheet.TitleBlock.Delete
If UBound(aStrings) >=0 Then
    oTitleBlock=oActiveSheet.AddTitleBlock(oNewTitleblockDef, ,aStrings)
Else
oTitleBlock=oActiveSheet.AddTitleBlock(oNewTitleblockDef)
End If
End If

If bOpen=True Then
oSource.Close(True)
Else
oSource=Nothing
End If

oTrans.End
Catch ex As Exception
oTrans.Abort
MsgBox(ex.Message,MsgBoxStyle.Critical,"iLogic Replace Titleblock" )
If Not oSource Is Nothing Then oSource.Close(True)
Finally
ThisApplication.ScreenUpdating=True
End Try

End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Guten Morgen,

wir haben es gleich getestet,
es funktioniert alles!
Vielen herzlichen Dank!

------------------
==========
MfG
Thomas

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