Code:
' für eine IPT
' eine Beschriftung ins Bauteil einfügenOption Explicit
'Konstanten (Einstellungen)
Const sVorlage As String = "C:\TEMP\meine_Vorlage.ipt" 'Datei, die (nur) eine Skizze der Beschriftung enthält
Const bRunRules As Boolean = True 'die iLogicRegeln aus der Vorlage werden einmalig ausgeführt (unabhängig von Eventtriggern)
'(ggf. neu erstellte, interne Regeln werden in jedem Fall ausgeführt)
' in meinem Bsp. nötig, sonst Fehler (da meine Ext. Regel einen Parameter erzeugt, der in der Skizze verwendet wird)
Const dExtrudeDistance As Double = 0.1 'Tiefe der Extrusion in mm (!)
'
Public Sub IPT_Beschriftung_erstellen()
'Konstanten (Einstellungen)
' -> auf Modulebene
'aktives Dokument (IPT sonst Fehler), hier wird die Beschriftung eingefügt
Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument
'Prüfung, ob Document bereits gespeichert wurde (sonst Fehler in ParametersInTB)
If 0 = oDoc.FileSaveCounter Then
MsgBox "Datei muss vorher gespeichert werden!", vbInformation, "Abgebrochen"
Exit Sub
End If
'Vorlage öffnen
Dim oVorlage As PartDocument
Set oVorlage = ThisApplication.Documents.Open(sVorlage, OpenVisible:=False)
If oVorlage Is Nothing Then Exit Sub 'Vorlage nicht gefunden o.ä.
' Den Ablauf in eine einzige Rückgängig-Aktion packen
Dim oTxnMgr As TransactionManager, oTxn As Transaction
Set oTxnMgr = ThisApplication.TransactionManager
'Start oTxn
Set oTxn = oTxnMgr.StartTransaction(oDoc, "Makro 'IPT_Beschriftung_erstellen'")
'iLogic-Regel(n) aus der Vorlage übernehmen (interne Regeln)
Call CopyInternalRules(oVorlage, oDoc)
'Ereignisauslöser / Event trigger aus Vorlage übernehmen
Call ReadEventTriggerProperty(oVorlage, oDoc)
'Skizze erstellen
Dim oNewSketch As Sketch
Set oNewSketch = CreateSketchUser(oDoc)
If oNewSketch Is Nothing Then 'Skizze erstellen hat nicht geklappt
Call oVorlage.Close(skipSave:=True) 'Vorlage schließen
oTxn.Abort 'die Transaction abbrechen!
MsgBox "Skizze konnte nicht erstellt werden." & vbCrLf & "Nichts passiert!", vbOKOnly, "Abgebrochen"
Exit Sub
End If
oNewSketch.Name = oNewSketch.Name & "_Beschriftung" 'Skizze umbenennen
'Skizze aus Vorlage
Dim oSourceSketch As Sketch
Set oSourceSketch = oVorlage.ComponentDefinition.Sketches.Item(1)
'es wird die erste Skizze aus der Vorlage verwendet (egal wie sie heißt)
'Inhalt der Skizze kopieren
Call oSourceSketch.CopyContentsTo(oNewSketch)
Call ParametersInTextBoxes(oSourceSketch, oNewSketch) 'siehe Sub unten
'Vorlage schließen
Call oVorlage.Close(skipSave:=True)
'Profile in der Skizze
Dim oProfile As Profile
Set oProfile = oNewSketch.Profiles.AddForSolid()
' Extrude the text.
Dim oCompDef As PartComponentDefinition
Set oCompDef = oDoc.ComponentDefinition
Dim oExtrudeDef As ExtrudeDefinition
Set oExtrudeDef = oCompDef.Features.ExtrudeFeatures.CreateExtrudeDefinition(oProfile, kCutOperation)
Call oExtrudeDef.SetDistanceExtent(dExtrudeDistance / 10, kNegativeExtentDirection) 'Maßangabe in cm
Dim oExtrude As ExtrudeFeature
Set oExtrude = oCompDef.Features.ExtrudeFeatures.Add(oExtrudeDef)
oExtrude.Name = oExtrude.Name & "_Beschriftung"
'Rückgängig-Aktion abschließen
oTxn.End
'Aufräumen
Set oTxn = Nothing
Set oTxnMgr = Nothing
Set oProfile = Nothing
Set oCompDef = Nothing
Set oExtrudeDef = Nothing
Set oExtrude = Nothing
Set oNewSketch = Nothing
Set oSourceSketch = Nothing
Set oVorlage = Nothing
Set oDoc = Nothing
End Sub
Private Function ReadEventTriggerProperty(ByRef oVorlage As Document, _
ByRef oTargetDoc As Document) As Variant
'Wert aus iProp lesen
' und übertragen ins oTargetDoc
'
' https://github.com/MegaJerk/iLogicCodeInjector/blob/master/Code%20Injector%20Project/Code%20Injector/Code_Injector.vb
'
' jeden Trigger aus der Vorlage ins aktive Document bringen
'Default-Rückgabewert (wenn Prop nicht existiert)
ReadEventTriggerProperty = ""
' Get the custom property set.
Dim customIPropSet As PropertySet
On Error Resume Next
Set customIPropSet = oVorlage.PropertySets.Item("{2C540830-0723-455E-A8E2-891722EB4C3E}")
On Error GoTo 0
If customIPropSet Is Nothing Then 'PropSet existiert nicht
MsgBox "Kein Trigger in der Vorlage", vbInformation, "ReadEventTriggerProperty"
Exit Function
End If
'Sonderfall (PropSet existiert, aber kein Trigger)
If 0 = customIPropSet.Count Then
MsgBox "Kein Trigger in der Vorlage", vbInformation, "ReadEventTriggerProperty"
Exit Function
End If
Dim propItemCounterTemplate As Integer
For propItemCounterTemplate = 1 To customIPropSet.Count Step 1
Dim propTemplate As Property
Set propTemplate = customIPropSet.Item(propItemCounterTemplate)
Dim sRuleVal As String
sRuleVal = propTemplate.Value
'AfterAnyiPropertyChange0 ID 1600
'AfterAnyiPropertyChange1 ID 1601
Dim iBaseID As Long
iBaseID = (Math.Abs(propTemplate.PropId / 100)) * 100 'macht aus 1605 -> 1600
Dim iRuleCounter As Integer
iRuleCounter = propTemplate.PropId - iBaseID
Dim sBaseName As String
sBaseName = Left$(propTemplate.Name, Len(propTemplate.Name) - Len(CStr(iRuleCounter)))
'aus AfterAnyiPropertyChange1 wird AfterAnyiPropertyChange
Call CopyTriggerToDocument(oTargetDoc, sRuleVal, sBaseName, iBaseID) 'Aufruf Sub unten
Next propItemCounterTemplate
'Aufräumen
On Error GoTo 0
Set customIPropSet = Nothing
End Function
Sub CopyTriggerToDocument(cDocument As Document, _
ruleName As String, TriggerPropName As String, BaseID As Long)
'cDocument: das aktive Dokument, in das die Regel kopiert werden soll
'sollten bereits EventTrigger gesetzt sein, bleiben diese erhalten
'sollte der 'neue' Trigger bereits vorhanden sein, bleibt er unverändert
'
'was, wenn sich die Regel im Dokument befindet? -> muss mit kop. werden!
'PropertySet, das die EventTrigger enthält
Dim customIPropSet As PropertySet
On Error Resume Next
Set customIPropSet = cDocument.PropertySets.Item("{2C540830-0723-455E-A8E2-891722EB4C3E}")
On Error GoTo 0
If customIPropSet Is Nothing Then 'PropSet existiert nicht
'erstellen!
Set customIPropSet = cDocument.PropertySets.Add("iLogicEventsRules", "{2C540830-0723-455E-A8E2-891722EB4C3E}")
End If
Dim propTemp As Property
Dim EndHolder As Integer, TriggerID As Long
EndHolder = 0 'Startwert
TriggerID = BaseID 'Startwert
If customIPropSet.Count > 0 Then
Do
On Error Resume Next
Set propTemp = customIPropSet.ItemByPropId(TriggerID)
On Error GoTo 0
If propTemp Is Nothing Then
'kein Trigger mit der gewünschten ID
'wird unten erstellt
Exit Do 'Schleife verlassen
ElseIf propTemp.Value = ruleName Then
'der gewünschte Trigger existiert bereits
' Verlassen der Schleife und
' das Erstellen wird übersprungen
GoTo RunRule 'schlechter Stil, sorry
Else
'Trigger mit der ID existiert, ist aber nicht der gewünschte
'Zähler erhöhen und dann von vorne
EndHolder = EndHolder + 1
TriggerID = TriggerID + 1
Set propTemp = Nothing
End If
Loop While EndHolder < 25 'Endlosschleife verhindern
Else 'keine Properties/Trigger in dem Set
'nix zu tun, Startwerte von EndHolder und TriggerID passen
End If
'Trigger erstellen
Call customIPropSet.Add(ruleName, TriggerPropName & EndHolder, TriggerID)
RunRule:
'externe Regeln ggf. ausführen, abhängig von Parameter auf Modulebene
Const sExtRegelMarker As String = "file://"
If bRunRules And InStr(ruleName, sExtRegelMarker) Then
'externe Regeln beginnen mit file://... anschließend auch relativer Pfad möglich
' (interne Regeln werden ggf. im Sub CopyInternalRules() bzw. CreateInternalRules() ausgeführt
' und hier übergangen)
Dim sExtRuleName As String
sExtRuleName = Replace$(ruleName, sExtRegelMarker, "", , 1) 'das file:// wird aus dem Namen entfernt
Call RuniLogicExtRule(sExtRuleName, cDocument) '
End If
'Aufräumen
Set propTemp = Nothing
Set customIPropSet = Nothing
End Sub
Private Sub Test_CopyInternalRules()
' nur zum Test des Sub unten
Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oVorlage As PartDocument 'Vorlage öffnen
Set oVorlage = ThisApplication.Documents.Open(sVorlage, OpenVisible:=False)
'iLogic-Regel(n) aus der Vorlage übernehmen (interne Regeln)
Call CopyInternalRules(oVorlage, oDoc)
'Vorlage schließen
Call oVorlage.Close(skipSave:=True)
End Sub
Private Sub CopyInternalRules(oVorlage As Document, oTargetDoc As Document)
'lesen der iLogic-Regeln aus der Vorlage
' und erstellen im oTargetDoc
'Get the iLogic-Addin
Dim iLogicAuto As Object
Set iLogicAuto = GetiLogicAddin(ThisApplication)
Dim oRules As Object
Set oRules = iLogicAuto.Rules(oVorlage)
'Regeln vorhanden? Nein -> Fertig
If oRules Is Nothing Then Exit Sub
Dim oRule As Object
For Each oRule In oRules
If oRule.IsActive Then
'die Regeln ist nicht unterdrückt
Call CreateInternalRule(oTargetDoc, oRule.Name, oRule.Text)
Else
'nix unterdrückte Regeln werden ignoriert
End If
Next 'oRule
'Aufräumen
Set iLogicAuto = Nothing
Set oRules = Nothing
Set oRule = Nothing
End Sub
Private Sub CreateInternalRule(activeDoc As Document, sRuleName As String, sRuleText As String)
' iLogic-Regel innerhalb eines Dokuments erstellen
' bereits existierende Regel wird ggf. nach Nachfrage überschrieben
' neu erstellte Regel wird ausgeführt
' existierende Regel wird ausgeführt nach Einstellung (Parameter auf Modulebene)
'
' Quelle:
' https://github.com/MegaJerk/iLogicCodeInjector/blob/master/Code%20Injector%20Project/Code%20Injector/Code_Injector.vb
' aus Sub CreateRule( ...)
'Get the iLogic-Addin
Dim iLogicAuto As Object
Set iLogicAuto = GetiLogicAddin(ThisApplication)
'Creates a new Object called rule.
Dim rule As Object
'using our new object, we'll attempt to get the rule from the active document that is named the same
'as the rule name that the user put in.
Set rule = iLogicAuto.GetRule(activeDoc, sRuleName)
'creates a new Object called exRule, that we will leave blank for now.
Dim exRule As Object
'if our rule Object doesn't equal anything (which means that it couldn't find a rule with the same
'name, then we'll do the following.
If (rule Is Nothing) Then
'We'll create a new rule in the current document, with our rule name, and our rule text
'By default when a rule is created, it is ran
Call iLogicAuto.AddRule(activeDoc, sRuleName, sRuleText)
Else
'If we're here, it means that we did find another rule in the document that had the same name
'as the rule we wanted to add.
'check against rule text to see if it equals current text
'if it does, do nothing, if it doesn't, prompt user for an overwrite
'Set our empty object to the rule that exists.
Set exRule = iLogicAuto.GetRule(activeDoc, sRuleName)
'If the rule in the document has the exact same text as the user entered text, then there is nothing to change.
If exRule.Text = sRuleText Then
'nichts zu tun
Else
'If the text doesn't match, then we'll let the user decide if they want to replace it.
Dim ret As VbMsgBoxResult
ret = MsgBox("Es existiert bereits eine Regel mit dem gleichen Namen aus der Vorlage, jedoch mit unterschiedlichem Inhalt. Vorhandene Regel überschreiben?", vbYesNo + vbQuestion, "Regel: " & sRuleName)
If vbYes = ret Then
exRule.Text = sRuleText
Else
Call MsgBox("Vorhandene Regel bleibt unverändert erhalten", vbOKOnly, "Regel: " & sRuleName)
End If
End If
'Regel ausführen (egal ob überschrieben oder nicht), abhängig von Konstante auf Modulebene
If bRunRules Then Call iLogicAuto.RunRule(activeDoc, sRuleName)
End If
'Aufräumen:
Set rule = Nothing
Set exRule = Nothing
Set iLogicAuto = Nothing
End Sub
Private Sub ParametersInTextBoxes(oSkVorlage As Sketch, oSkNew As Sketch)
'beim Kopieren von Textboxen in eine andere Skizze gehen verwendete Parameter verloren
'der Code hier stellt das gewünschte Verhalten her (dass Parameter verwendet werden)
' die verwendeten Parameter müssen auch im neuen Teil existieren!
' -> das sollte ggf. noch als Prüfung hier rein!
Dim oTB As TextBox, oTBNew As TextBox
Dim sFormTxt As String 'FormattedText der Vorlage
Dim i As Long 'Zähler für die Schleife
If 0 = oSkVorlage.TextBoxes.Count Then Exit Sub 'Sonderfall: Vorlage ohne Textbox
Dim sFileVorlage As String, sFileTarget As String
sFileVorlage = oSkVorlage.Parent.Document.fullFilename
sFileTarget = oSkNew.Parent.Document.fullFilename
Debug.Print sFileVorlage
Debug.Print sFileTarget
For i = 1 To oSkVorlage.TextBoxes.Count 'Schleife über alle Textboxen
Set oTB = oSkVorlage.TextBoxes.Item(i) 'TB der Vorlage
Set oTBNew = oSkNew.TextBoxes.Item(i) 'TB Kopie
sFormTxt = oTB.FormattedText
If InStr(sFormTxt, "<Parameter ") Then
'Dateiname der Vorlage gegen den der aktuellen Datei austauschen
Debug.Print sFormTxt
sFormTxt = Replace$(sFormTxt, sFileVorlage, sFileTarget)
Debug.Print sFormTxt
'FormattedText der Neuen TextBox zuweisen
oTBNew.FormattedText = sFormTxt
End If
Next i
' Parameter sehen im FormattedText so aus:
' <Parameter Resolved='True' ComponentIdentifier='O:\Path\File.ipt' Name='Parameter_Name' Precision='3'>Parameter_Value</Parameter>
' es wird der FormattedText der VorlagenTB in die KopieTB übertragen
' vorher jedoch der Dateiname ersetzt
End Sub
Private Function CreateSketchUser(oDoc As PartDocument) As Sketch
' User wird aufgefordert eine Fläche zu wählen
' darauf wird dann eine neue Skizze erzeugt, diese ist zunächst leer
If oDoc Is Nothing Then Exit Function
Dim oCmdMgr As CommandManager
Set oCmdMgr = ThisApplication.CommandManager
Dim oFace As Face
Set oFace = oCmdMgr.Pick(kPartFacePlanarFilter, "Select planar face for new sketch")
If oFace Is Nothing Then Exit Function 'falls User abbricht
Dim oSketch As Sketch
Set oSketch = oDoc.ComponentDefinition.Sketches.Add(oFace)
Set CreateSketchUser = oSketch 'Rückgabewert der Function
End Function
'-----
' https://forums.autodesk.com/t5/inventor-customization/run-ilogic-external-rule-with-inventor-vba/m-p/6270622#M63195
Private Sub Example_RunRule()
RuniLogicExtRule ("C:\Path\MyRule.iLogicVb")
End Sub
Public Sub RuniLogicExtRule(ByVal ruleName As String, Optional oDoc As Document)
' als RuleName funktionieren auch relative Pfade
' IV sucht u.a. in den Verzeichnissen für externe Regeln (unter iLogic-Konfiguration)
' Dateiendung ist nicht erforderlich
'oDoc jetzt optionaler Parameter
Dim iLogicAuto As Object
If oDoc Is Nothing Then Set oDoc = ThisApplication.ActiveDocument
If oDoc Is Nothing Then
MsgBox "Missing Inventor Document"
Exit Sub
End If
Set iLogicAuto = GetiLogicAddin(ThisApplication)
If (iLogicAuto Is Nothing) Then Exit Sub
iLogicAuto.RunExternalRule oDoc, ruleName
End Sub
Private Function GetiLogicAddin(oApplication As Inventor.Application) As Object
Dim addIn As ApplicationAddIn
On Error GoTo NotFound
Set addIn = oApplication.ApplicationAddIns.ItemById("{3bdd8d79-2179-4b11-8a5a-257b1c0263ac}")
If (addIn Is Nothing) Then Exit Function
addIn.Activate
Set GetiLogicAddin = addIn.Automation
Exit Function
NotFound:
End Function
'----
Foren auf CAD.de (alle Foren)
| 
) noch. 
für sinnvoll hält) und die Elemente der Skizze befinden sich bzgl SkizzenKS an der gleichem Position, wie in der Vorlage. Hier wäre es evtl noch sinnvoll den Ursprung und ggf Orientierung vom User wählen zu lassen (ähnlich wie im Code von Ralf). Wie gesagt, bis jetzt noch nicht enthalten.
