Hot News aus dem CAD.de-Newsletter:

Mit Unterstützung durch:

  Foren auf CAD.de (alle Foren)
  Inventor
  Stempaln / Markiere....

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
Autor Thema:   Stempaln / Markiere.... (434 mal gelesen)
F.Engelbrecht
Mitglied
Metallbauermeister/Schweißfachmann/

Sehen Sie sich das Profil von F.Engelbrecht an!   Senden Sie eine Private Message an F.Engelbrecht  Schreiben Sie einen Gästebucheintrag für F.Engelbrecht

Beiträge: 9
Registriert: 03.09.2008

erstellt am: 16. Jun. 2020 10:12    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Mahlzeit zusammen:

Ich hab da gerne mal nen Problem, Wir würden unseren Bauteilen im Cad Gerne so ne Art Stempel verpassen was dann auf den Bauteilen z.b. Blechteile drauf ist.
Mit unserem Zeichen Bauteilnummer und Zeichnungsnummer...
Also nicht den umständlichen Weg mit skizze usw......., gibt es da ne einfachere Möglichkeit das man sich irgendwie ne Vorlage macht wo die Iproperties ausgelesen werden und man das einfach setzt?

Ich stöbere da nun schon ein paar Tage, aber gefunden habe ich dazu nicht wirklich etwas interessantes.

Gruß

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

Manfred Gündchen
Ehrenmitglied V.I.P. h.c.
SelbstständIng mit Planungsbüro Anlagenbau, Dipl.-Ing.-Maschinenbau


Sehen Sie sich das Profil von Manfred Gündchen an!   Senden Sie eine Private Message an Manfred Gündchen  Schreiben Sie einen Gästebucheintrag für Manfred Gündchen

Beiträge: 2024
Registriert: 08.03.2008

IV seit den 5.3Er
aktuell den 2014Ner
WIN7pro-64bit
SP das jeweils aktuelle

erstellt am: 16. Jun. 2020 10:17    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

…na auf die Antworten bin ich selbst gespannt.
„Normalerweise“ brauch der IV immer eine Skizze, auch wenn die im Hintergrund automatisch angelegt werden sollte, um Datenbankdaten an eine gewünschte Position in einer gewünschten Größe unterzubringen…

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

Manfred Gündchen
Ehrenmitglied V.I.P. h.c.
SelbstständIng mit Planungsbüro Anlagenbau, Dipl.-Ing.-Maschinenbau


Sehen Sie sich das Profil von Manfred Gündchen an!   Senden Sie eine Private Message an Manfred Gündchen  Schreiben Sie einen Gästebucheintrag für Manfred Gündchen

Beiträge: 2024
Registriert: 08.03.2008

IV seit den 5.3Er
aktuell den 2014Ner
WIN7pro-64bit
SP das jeweils aktuelle

erstellt am: 16. Jun. 2020 11:20    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

…ach ja eine Frage (mindestens  ) noch.
Sollen die Daten per CAM verwendet werden?
ZB. als Lasergravur oder Ähnliches?

------------------
In diesem Sinne wünsche ich allen, weiterhin effektives Schaffen

----------------
Manfred Gündchen
www.guendchen.com

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

F.Engelbrecht
Mitglied
Metallbauermeister/Schweißfachmann/

Sehen Sie sich das Profil von F.Engelbrecht an!   Senden Sie eine Private Message an F.Engelbrecht  Schreiben Sie einen Gästebucheintrag für F.Engelbrecht

Beiträge: 9
Registriert: 03.09.2008

erstellt am: 16. Jun. 2020 11:21    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Mahlzeit,

ja die Daten werden dann von unserem Laser mit drauf Graviert.
Langt aber z.b. wenn das ganze eine 0,5mm Extrusion oder auch eine Prägung währe, das erkennt unser Laser Programm als Beschriftung, das haben wir schon getestet.

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 318
Registriert: 19.09.2007

Inventor Professional 2016
Win7

erstellt am: 16. Jun. 2020 13:51    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

ein (kleiner) Teil des Problems ist hier behandelt
Dateiname in Skizze
iProperty in einen Parameter schreiben mit iLogic
Parameter kann man ja in einen Skizzentext einbinden (im Gegensatz zu iProperties).

Ich dachte, man könnte daraus ein iFeature bauen. Geht wohl nicht mit einem Text. (dazu habe ich auch einen Beitrag hier im Forum gefunden von ~2013. Scheint bei mir mit IV2016 auch zutreffend)

------------------
Gruß KraBBy

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

rkauskh
Ehrenmitglied
Dipl.-Ing. (FH) Versorgungstechnik


Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 1611
Registriert: 15.11.2006

Windows 7 x64, AIS 2014

erstellt am: 17. Jun. 2020 18:58    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

Hallo

Eine ganz einfache Lösung wird's vermutlich nicht geben. Was heißt "unser Zeichen"? Ein Bild? Oder nur der Firmenname?
Das Makro erzeugt aus zwei iProps eine Differenzextrusion in etwa mittig auf der gewählten Fläche. Geht nicht komplett von allein, ist aber schneller als ganz zu Fuß. 

Code:

Option Explicit

Public Sub CreateSimpleLaserStamp()

Dim oInv As Inventor.Application
Set oInv = ThisApplication

If Not oInv.ActiveDocument.DocumentType = kPartDocumentObject Then
    MsgBox "Nur im Bauteil möglich. Abbruch", vbCritical
    Exit Sub
End If
   
Dim oPartDoc As PartDocument
Set oPartDoc = ThisApplication.ActiveDocument

Dim oCompDef As PartComponentDefinition
Set oCompDef = oPartDoc.ComponentDefinition

Dim sProp1 As String
Dim sProp2 As String
Dim oProp As Property

For Each oProp In oPartDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
    If oProp.Name = "Bauteilnummer" Then sProp1 = oProp.Value
    If oProp.Name = "Zeichnungsnummer" Then sProp2 = oProp.Value
Next

If sProp1 = "" Or sProp2 = "" Then
    MsgBox "Fehlende Daten in iProp Bauteil- und/oder Zeichnungsnummer. Abbruch", vbCritical
End If

Dim oFace As Face
Set oFace = oInv.CommandManager.Pick(kPartFacePlanarFilter, "Planare Fläche auswählen...")

If oFace Is Nothing Then Exit Sub

Dim outerLoop As EdgeLoop
For Each outerLoop In oFace.EdgeLoops
    If outerLoop.IsOuterEdgeLoop Then
        Exit For
    End If
Next

Dim oXAxis As Object
Set oXAxis = oInv.CommandManager.Pick(kAllLinearEntities, "Kante als X-Achse wählen...")

Dim oWorkPoint As WorkPoint
Set oWorkPoint = oCompDef.WorkPoints.AddAtCentroid(outerLoop)
       
Dim oSketch As PlanarSketch
Set oSketch = oPartDoc.ComponentDefinition.Sketches.AddWithOrientation(oFace, oXAxis, False, True, oWorkPoint)

Dim oTransGeom As TransientGeometry
Set oTransGeom = ThisApplication.TransientGeometry

Dim oTextBox As TextBox
Set oTextBox = oSketch.TextBoxes.AddFitted(oTransGeom.CreatePoint2d(0, 0), sProp1 & vbCrLf & sProp2)

Dim oPaths As ObjectCollection
Set oPaths = ThisApplication.TransientObjects.CreateObjectCollection
oPaths.Add oTextBox
   
Dim oProfile As Profile
Set oProfile = oSketch.Profiles.AddForSolid(False, oPaths)

Dim oExtrudeDef As ExtrudeDefinition
Set oExtrudeDef = oCompDef.Features.ExtrudeFeatures.CreateExtrudeDefinition(oProfile, kCutOperation)

Call oExtrudeDef.SetDistanceExtent(0.05, kNegativeExtentDirection)
   
Dim oExtrude As ExtrudeFeature
Set oExtrude = oCompDef.Features.ExtrudeFeatures.Add(oExtrudeDef)

oWorkPoint.Visible = False

End Sub


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

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy  an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 318
Registriert: 19.09.2007

Inventor Professional 2016
Win7

erstellt am: 27. Jun. 2020 18:20    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

Nun habe ich mich eine Weile mit dem Problem beschäftigt. Dabei kam folgender Vorschlag zustande:

In einer Datei "Vorlage.ipt", befindet sich eine (1) Skizze mit dem gewünschten Text. Es können auch weitere Elemente in der Skizze enthalten sein, zb ein Logo. Außerdem enthält die Vorlage ilogic Regeln und EreignisAuslöser(trigger), die dafür sorgen, dass die gewünschten iProperties in BenutzerParameter geschrieben und synchron gehalten werden. Das können Regeln im Dokument oder auch externe Regeln sein. Siehe auch der link in meinem vorigen Post.

Mit dem Makro unten wird die Skizze der Vorlage in das aktuelle Dokument kopiert. Auch die ilogic Regeln und trigger werden übertragen. Dh es werden die iProperties vom aktiven Dokument verwendet und diese werden auch aktuell gehalten (über die trigger). Mit der Skizze wird eine extrusion erzeugt.

Der Benutzer wird aufgefordert eine Fläche für die Skizze zu wählen. Bis jetzt ist das Koordinatensystem (KS) unverändert (so wie es die DIVA 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.

------------------
Gruß KraBBy

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy  an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 318
Registriert: 19.09.2007

Inventor Professional 2016
Win7

erstellt am: 27. Jun. 2020 18:24    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für F.Engelbrecht 10 Unities + Antwort hilfreich

Code:
' für eine IPT
' eine Beschriftung ins Bauteil einfügen

Option 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

'----


------------------
Gruß KraBBy

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2020 CAD.de | Impressum | Datenschutz