| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
Autor
|
Thema: Auflösung/Größe Thumbnail (1081 mal gelesen)
|
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 23. Nov. 2021 10:01 <-- editieren / zitieren --> Unities abgeben:
Hallo, brauche nochmal Hilfe. Gibt es eine Möglichkeit die Größe/Auflösung der Vorschaubilder beim Stücklistenexport der .iam nach Excel zu ändern? Wir verwenden IV2021 und würden die Vorschaubilder auch für das ERP verwenden. Leider sind die Bilder aber sehr klein mit geringer Auflösung. Vielen Dank inzwischen... Hans Peter ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 24. Nov. 2021 17:31 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 24. Nov. 2021 23:29 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Das Thumbnail ist nicht veränderlich. Bleiben die Bilder in der Exceltabelle oder wo liegen die Bilder, damit das ERP darauf zugreifen kann? Werden die Bilder in der Datenbank des ERP gespeichert oder liegen die extern auf einem Share? Wie wird die Stückliste übergeben? Ist das ein Script in dem man etwas ergänzen oder dazwischen springen kann? So in etwa sollte das funktionieren. Ist iLogic, kann man aber auch in VBA übersetzen. Code:
Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.FileName(False) Dim oTrans As Transaction= oApp.TransactionManager.StartTransaction(oDoc, "PicEX ") Dim oCurView As View= oApp.ActiveViewTry oApp.ScreenUpdating = False Dim oView As View= oDoc.Views.Add() Dim oCamera As Camera= oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap("C:\Temp\" & sFilename & ".jpg", 1920, 1080, oColor) oView.Close oCurView.Activate Catch Finally oTrans.Abort oApp.ScreenUpdating = True oDoc.Update End Try
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 25. Nov. 2021 09:23 <-- editieren / zitieren --> Unities abgeben:
Zitat: Original erstellt von rkauskh: HalloDas Thumbnail ist nicht veränderlich. Bleiben die Bilder in der Exceltabelle oder wo liegen die Bilder, damit das ERP darauf zugreifen kann? Werden die Bilder in der Datenbank des ERP gespeichert oder liegen die extern auf einem Share? Wie wird die Stückliste übergeben? Ist das ein Script in dem man etwas ergänzen oder dazwischen springen kann? So in etwa sollte das funktionieren. Ist iLogic, kann man aber auch in VBA übersetzen. Code:
Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.FileName(False) Dim oTrans As Transaction= oApp.TransactionManager.StartTransaction(oDoc, "PicEX ") Dim oCurView As View= oApp.ActiveViewTry oApp.ScreenUpdating = False Dim oView As View= oDoc.Views.Add() Dim oCamera As Camera= oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap("C:\Temp\" & sFilename & ".jpg", 1920, 1080, oColor) oView.Close oCurView.Activate Catch Finally oTrans.Abort oApp.ScreenUpdating = True oDoc.Update End Try
Hallo Ralf, ich schon wieder. vielen Dank. Damit können wir super arbeiten. Hab den Pfad noch dazugenommen. Leider kommt nach einer Änderung beim Ausführen ein Fehler. Auch bei deiner Regel funkt das beim 2. mal ausführen nach einer Änderung nicht. (Hab es bei einer Baugruppe verucht) Kannst du mir da helfen? Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.PathAndFileName(False) Dim oTrans As Transaction= oApp.TransactionManager.StartTransaction(oDoc, "PicEX ") Dim oCurView As View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As View= oDoc.Views.Add() Dim oCamera As Camera= oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color = oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sFilename & ".jpg", 1920, 1080, oColor) oView.Close oCurView.Activate Catch Finally oTrans.Abort oApp.ScreenUpdating = True
oDoc.Update End Try ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 25. Nov. 2021 11:31 <-- editieren / zitieren --> Unities abgeben:
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 25. Nov. 2021 15:03 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Ergänze mal bitte die Catch Anweisung was in der Fehlermeldung dann drin steht. Was wurde wie geändert? Hab jetzt einige Varianten durchprobiert ohne Fehler. Läuft der Code über einen Trigger (welcher?) oder manuell ausgelöst? Wenn nach dem ersten Durchlauf das Bild manuell gelöscht wird, kommt der Fehler dann trotzdem? Code:
Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.PathAndFileName(False) Dim oTrans As Transaction= oApp.TransactionManager.StartTransaction(oDoc, "PicEX ") Dim oCurView As View= oApp.ActiveViewTry oApp.ScreenUpdating = False Dim oView As View= oDoc.Views.Add() Dim oCamera As Camera= oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sFilename & ".jpg", 1920, 1080, oColor) oView.Close oCurView.Activate Catch ex As Exception MsgBox(ex.Message) Finally oTrans.Abort oApp.ScreenUpdating = True oDoc.Update End Try
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 25. Nov. 2021 15:33 <-- editieren / zitieren --> Unities abgeben:
Hallo Ralf, Code:
Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.PathAndFileName(True) Dim oTrans As Transaction= oApp.TransactionManager.StartTransaction(oDoc, "PicEX ") Dim oCurView As View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As View= oDoc.Views.Add() Dim oCamera As Camera= oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color = oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sFilename & ".jpg", 1920, 1080, oColor) oView.Close oCurView.Activate Catch ex As Exception MsgBox(ex.Message) Finally oTrans.Abort oApp.ScreenUpdating = True
oDoc.Update End Try
Ich hab eigentlich nur Zeile 4 Dim sFilename As String = ThisDoc.PathAndFileName(True) und Zeile 17 geändert Call oCamera.SaveAsBitmap(sFilename & ".jpg", 1920, 1080, oColor) Funktioniert auch soweit super. Der Code läuft vor dem Speichern von Dokument. Der Fehler taucht nur auf, sobald ich ein Teil in der Baugruppe lösche und nochmal speichern möchte. Dann stürzt IV komplett ab. ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 25. Nov. 2021 20:43 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Warum genau er da den Transactionsabbruch nicht mag weiß ich grade auch nicht. Geht aber auch ohne. Mit der Variante tritt der Fehler nicht mehr auf. Code:
Option Explicit on Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document Dim sFilename As String = ThisDoc.PathAndFileName(False) Dim oCurView As Inventor.View= oApp.ActiveViewTry oApp.ScreenUpdating = False Dim oView As Inventor.View = oDoc.Views.Add() oView.Visible = False Dim oCamera As Camera = oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sFilename & ".jpg", 1920, 1080, oColor) oView.Close Catch ex As Exception MsgBox(ex.Message) Finally oApp.ScreenUpdating = True End Try
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 26. Nov. 2021 11:13 <-- editieren / zitieren --> Unities abgeben:
|
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 26. Nov. 2021 15:41 <-- editieren / zitieren --> Unities abgeben:
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 26. Nov. 2021 16:02 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Wenn das in einer Vorlage steckt und du das erste Mal speicherst, vermute ich das ThisDoc.PathAndFileName noch leer ist. Das wird ja intern wahrscheinlich vom Document.FullFilename abgeleitet. Du könntest prüfen, ob der leer ist. Dann müßte man schauen ob und wie man alternativ den Pfad und Dateinamen für den Export generiert. Das wäre wieder ein Vorteil eines Addins. Dort kann man aus dem Context des OnSave Events unter anderem den FullFileName auslesen, in den das Dokument gespeichert werden soll. Aber wenn es mit "Nach dem Speichern" funktioniert, einfach lassen und nicht rumfummeln. ------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 29. Nov. 2021 16:13 <-- editieren / zitieren --> Unities abgeben:
Hallo Ralf, ich habe 2 externe Regeln für einen stp export mit MBD und eben die Bilder aktiv. Es ist jetzt doch nicht ganz so einfach. Beim Befehl speichern unter werden die Dateien (stp und Bild) vom ursprünglichen Teil überschrieben und vom neuen Teil wird nichts erstellt. Hast du vielleicht eine Idee wie ich das lösen könnte? Code:
' Get the STEP translator Add-In. Dim sPath As String = ThisDoc.Path Dim sFile As String = ThisDoc.FileName (True) Dim oSTEPTranslator As TranslatorAddIn oSTEPTranslator = ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}") Dim oContext As TranslationContext oContext = ThisApplication.TransientObjects.CreateTranslationContext Dim oOptions As NameValueMap oOptions = ThisApplication.TransientObjects.CreateNameValueMapIf oSTEPTranslator.HasSaveCopyAsOptions(ThisDoc.Document, oContext, oOptions) Then ' Set application protocol. ' 2 = AP 203 - Configuration Controlled Design ' 3 = AP 214 - Automotive Design oOptions.Value("ApplicationProtocolType") = 5 ' Other options... 'oOptions.Value("Author") = "" 'oOptions.Value("Authorization") = "" 'oOptions.Value("Description") = "" 'oOptions.Value("Organization") = "" oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism Dim oData As DataMedium oData = ThisApplication.TransientObjects.CreateDataMedium oData.FileName = sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".stp" oSTEPTranslator.SaveCopyAs(ThisDoc.Document, oContext, oOptions, oData) End If
und eben Code:
Option Explicit On Dim oApp As Inventor.Application = ThisApplication Dim oDoc As Document = ThisDoc.Document 'Dim sFilename As String = ThisDoc.PathAndFileName(True) Dim sPath As String = ThisDoc.Path Dim sFile As String = ThisDoc.FileName (True) Dim oCurView As Inventor.View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As Inventor.View = oDoc.Views.Add() oView.Visible = FalseDim oCamera As Camera = oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".jpg", 1920, 1080, oColor) oView.Close Catch ex As Exception MsgBox(ex.Message) Finally oApp.ScreenUpdating = True End Try
Danke inzwischen und Grüße ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 29. Nov. 2021 21:23 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Doch, ist einfach (zu erklären). Das OnSave-Event wird im Originaldokument ausgelöst. In dessen Kontext läuft dann auch die Regel, daher ist ThisDoc das Original. Das dann eine Kopie mit neuem Namen gespeichert wird, ändert daran nichts. Die Unterscheidung und angepasste Reaktion ermöglicht der iLogic Eventhandler nicht. Dort fehlen die notwendigen Kontextinfos. ------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 30. Nov. 2021 07:48 <-- editieren / zitieren --> Unities abgeben:
Hallo Ralf, vielen Dank. Ein weiteres Problem ist jetzt aufgetaucht: beim benutzerdefinierten einfügen von Inhaltcenter-Dateien stürzt IV bei der Bild Regel ab. Die stp-Regel läuft durch. Kannst du mir da nochmal helfen? Danke ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 01. Dez. 2021 15:59 <-- editieren / zitieren --> Unities abgeben:
Hallo, hab jetzt einen anderen Ansatz der für mich noch besser passen würde. Die 2 Regeln in einer übergeordneten Baugruppe manuell starten für alle Teile der Unterbaugruppe durchlaufen lassen. Mein Versuch mit diesem Code den ich auch im Forum gefunden habe ist kläglich gescheitert. Bitte nochmal um eure Hilfe!! Code:
Dim asmDoc As AssemblyDocument = ThisApplication.ActiveDocument Dim tmpDoc As Document For Each tmpDoc In asmDoc.AllReferencedDocuments ' liefert Alle untergeordneten Elemente, inkl. Komp. aus Unterbgr. 'For Each tmpDoc In asmDoc.ReferencedDocuments ' liefert nur die Komponenten der aktiven Bgr.; oberste Ebene If TypeOf tmpDoc Is AssemblyDocument then '... ElseIf tmpDoc.ComponentDefinition.IsContentMember then '... Else '... End If Next
Danke ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 01. Dez. 2021 21:17 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Der Absturz tritt im 2022er nicht mehr auf. Hilft dir aktuell aber sicher auch nicht weiter. Ich habe einige Konstellationen durchprobiert, aber keine hat stabil funktioniert. Du kannst deine beiden Regeln beispielsweise in eigene Prozeduren kapseln und sie in deiner Schleife aus einer übergeordneten Prozedur aufrufen. Das jeweilige Document übergibst du als Argument. Das macht es etwas übersichtlicher. Code:
Private Sub Main Dim asmDoc As AssemblyDocument = ThisDoc.Document Dim tmpDoc As Document For Each tmpDoc In asmDoc.AllReferencedDocuments ' liefert Alle untergeordneten Elemente, inkl. Komp. aus Unterbgr. 'For Each tmpDoc In asmDoc.ReferencedDocuments ' liefert nur die Komponenten der aktiven Bgr.; oberste Ebene If TypeOf tmpDoc Is AssemblyDocument Then '... ElseIf tmpDoc.ComponentDefinition.IsContentMember Then '... Else '... SaveAsImage(tmpDoc) SaveAsSTEP(tmpDoc) End If Next End SubPrivate Sub SaveAsSTEP(ByVal oDoc As Document) ' Get the STEP translator Add-In. Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileNameWithoutExtension(oDoc.FullFileName) Dim oSTEPTranslator As TranslatorAddIn= ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}") Dim oContext As TranslationContext= ThisApplication.TransientObjects.CreateTranslationContext Dim oOptions As NameValueMap= ThisApplication.TransientObjects.CreateNameValueMap If oSTEPTranslator.HasSaveCopyAsOptions(oDoc, oContext, oOptions) Then ' Set application protocol. ' 2 = AP 203 - Configuration Controlled Design ' 3 = AP 214 - Automotive Design oOptions.Value("ApplicationProtocolType") = 5 ' Other options... 'oOptions.Value("Author") = "" 'oOptions.Value("Authorization") = "" 'oOptions.Value("Description") = "" 'oOptions.Value("Organization") = "" oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism Dim oData As DataMedium = ThisApplication.TransientObjects.CreateDataMedium oData.FileName = sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".stp" oSTEPTranslator.SaveCopyAs(oDoc, oContext, oOptions, oData) End If End Sub Private Sub SaveAsImage(ByVal oDoc As Document) Dim oApp As Inventor.Application = ThisApplication 'Dim sFilename As String = ThisDoc.PathAndFileName(True) Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileNameWithoutExtension(oDoc.FullFileName) Dim oCurView As Inventor.View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As Inventor.View = oDoc.Views.Add() oView.Visible = False Dim oCamera As Camera = oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".jpg", 1920, 1080, oColor) oView.Close Catch ex As Exception MsgBox(ex.Message) Finally oApp.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 |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 06. Dez. 2021 09:09 <-- editieren / zitieren --> Unities abgeben:
|
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 28. Feb. 2022 17:33 <-- editieren / zitieren --> Unities abgeben:
Hallo, ich möchte jetzt auch die Abwicklungen der Blechteile automatisch abspeichern und ein 3D pdf erstellen. Bis zum Bild funktioniert alles. Es kommt aber schon beim 1. dxf ein Ausnahmefehler. Was hab ich falsch? Code: Private Sub Main Dim asmDoc As AssemblyDocument = ThisDoc.Document Dim tmpDoc As Document For Each tmpDoc In asmDoc.AllReferencedDocuments ' liefert Alle untergeordneten Elemente, inkl. Komp. aus Unterbgr. If TypeOf tmpDoc Is AssemblyDocument Then SaveAsImage(tmpDoc) SaveAsSTEP(tmpDoc) ElseIf tmpDoc.ComponentDefinition.IsContentMember Then '... Else '... SaveAsImage(tmpDoc) SaveAsSTEP(tmpDoc) SaveAsdxf(tmpDoc) End If Next'Dim oDoc As AssemblyDocument = ThisDoc.Document 'Dim tmpDoc As Document Dim sPath As String = System.IO.Path.GetDirectoryName(asmDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileNameWithoutExtension(asmDoc.FullFileName) ThisBOM.Export(“Structured”, sPath & "\PDM_IMPORT\" & sFile & ".csv", kTextFileCommaDelimitedFormat) End Sub Private Sub SaveAsSTEP(ByVal oDoc As Document) ' Get the STEP translator Add-In. Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) Dim oSTEPTranslator As TranslatorAddIn= ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}") Dim oContext As TranslationContext= ThisApplication.TransientObjects.CreateTranslationContext Dim oOptions As NameValueMap= ThisApplication.TransientObjects.CreateNameValueMap If oSTEPTranslator.HasSaveCopyAsOptions(oDoc, oContext, oOptions) Then ' Set application protocol. ' 2 = AP 203 - Configuration Controlled Design ' 3 = AP 214 - Automotive Design oOptions.Value("ApplicationProtocolType") = 5 ' Other options... 'oOptions.Value("Author") = "" 'oOptions.Value("Authorization") = "" 'oOptions.Value("Description") = "" 'oOptions.Value("Organization") = "" oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism Dim oData As DataMedium = ThisApplication.TransientObjects.CreateDataMedium oData.FileName = sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".stp" oSTEPTranslator.SaveCopyAs(oDoc, oContext, oOptions, oData) End If End Sub Private Sub SaveAsImage(ByVal oDoc As Document) Dim oApp As Inventor.Application = ThisApplication 'Dim sFilename As String = ThisDoc.PathAndFileName(True) Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) Dim oCurView As Inventor.View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As Inventor.View = oDoc.Views.Add() oView.Visible = False Dim oCamera As Camera = oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".jpg", 1920, 1080, oColor) oView.Close Catch ex As Exception MsgBox(ex.Message) Finally oApp.ScreenUpdating = True End Try End Sub Private Sub SaveAsdxf(ByVal oDoc As Document) 'oDoc = ThisApplication.ActiveDocument Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) 'Prüfen ob Datei ein Blech ist und falls keine Abwicklnug vorhanden Abwicklung erstellen If oDoc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then oFlatPattern = oDoc.ComponentDefinition.FlatPattern oSheetMetalCompDef = oDoc.ComponentDefinition If oSheetMetalCompDef.HasFlatPattern = False Then oSheetMetalCompDef.Unfold Else 'Abbrechen, wenn kein Blechbauteil Exit Sub End If 'Dateiname ohne Extension ermitteln und Exporterweiterung anhängen 'Dim Dateiname As String 'Dateiname = Left(oDoc.FullFileName, Len(oDoc.FullFileName) - 3) & Ext 'Export der Abwicklung durchführen Dim sOut As String sOut = "FLAT PATTERN DXF?AcadVersion=2004&OuterProfileLayer=IV_OUTER_PROFILE&InteriorProfilesLayer=IV_INTERIOR_PROFILES&InvisibleLayers=IV_FEATURE_PROFILES_DOWN;IV_TANGENT;IV_BEND;IV_BEND_DOWN;I V_FEATURE_PROFILES;IV_FEATURE_PROFILES&OuterProfileLayerColor=255,0,0" Dim sFname As String sFname = sPath & "\PDM_IMPORT\" & sFile & "\Abwicklung\" & sFile & ".dxf" oSheetMetalCompDef.DataIO.WriteDataToFile( sOut, sFname) 'oDoc = ThisApplication.ActiveDocument Dim oSMDef As SheetMetalComponentDefinition oSMDef = oDoc.ComponentDefinition oSMDef.FlatPattern.ExitEdit End Sub
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 28. Feb. 2022 20:36 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo 1. In deinem String sOut sind Leerzeichen enthalten, die da nicht sein dürften. 2. WriteDataToFile geht davon aus, dass der Pfad existiert. Ansonsten gibt es einen Fehler. Also vorher prüfen und ggf. anlegen (System.IO.Directory.CreateDirectory). ------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 01. Mrz. 2022 18:08 <-- editieren / zitieren --> Unities abgeben:
Haha super, das geht jetzt top. Jetzt noch die Abmessungen der Abwicklung in einem Benutzerdefinierten I-Prop schreiben. Hab das auch hier aus dem Netz, das will aber nicht. Ich bastel mich so durch... Kannst du auf den Code ganz zum Schluss bitte einen Blick werfen? Läuft zwar ohne Fehler, aber ich bekomme keine Benutzerdefinierte Iprops (Ich möchte das gern so machen, weil wir die Abwicklung manchmal bearbeiten und so die Blechdicke von der Dicke der Abwicklung abweicht
Code:
Private Sub Main Dim asmDoc As AssemblyDocument = ThisDoc.Document Dim tmpDoc As Document For Each tmpDoc In asmDoc.AllReferencedDocuments ' liefert Alle untergeordneten Elemente, inkl. Komp. aus Unterbgr. If TypeOf tmpDoc Is AssemblyDocument Then SaveAsImage(tmpDoc) SaveAsSTEP(tmpDoc) ElseIf tmpDoc.ComponentDefinition.IsContentMember Then '... Else '... SaveAsImage(tmpDoc) SaveAsSTEP(tmpDoc) SaveAsdxf(tmpDoc) End If Next'Dim oDoc As AssemblyDocument = ThisDoc.Document 'Dim tmpDoc As Document Dim sPath As String = System.IO.Path.GetDirectoryName(asmDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileNameWithoutExtension(asmDoc.FullFileName) System.IO.Directory.CreateDirectory (sPath & "\PDM_IMPORT\") ThisBOM.Export(“Structured”, sPath & "\PDM_IMPORT\" & sFile & ".csv", kTextFileCommaDelimitedFormat) End Sub Private Sub SaveAsSTEP(ByVal oDoc As Document) ' Get the STEP translator Add-In. Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) Dim oSTEPTranslator As TranslatorAddIn= ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}") Dim oContext As TranslationContext= ThisApplication.TransientObjects.CreateTranslationContext Dim oOptions As NameValueMap= ThisApplication.TransientObjects.CreateNameValueMap If oSTEPTranslator.HasSaveCopyAsOptions(oDoc, oContext, oOptions) Then ' Set application protocol. ' 2 = AP 203 - Configuration Controlled Design ' 3 = AP 214 - Automotive Design oOptions.Value("ApplicationProtocolType") = 5 ' Other options... 'oOptions.Value("Author") = "" 'oOptions.Value("Authorization") = "" 'oOptions.Value("Description") = "" 'oOptions.Value("Organization") = "" oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism Dim oData As DataMedium = ThisApplication.TransientObjects.CreateDataMedium oData.FileName = sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".stp" oSTEPTranslator.SaveCopyAs(oDoc, oContext, oOptions, oData) End If End Sub Private Sub SaveAsImage(ByVal oDoc As Document) Dim oApp As Inventor.Application = ThisApplication 'Dim sFilename As String = ThisDoc.PathAndFileName(True) Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) Dim oCurView As Inventor.View= oApp.ActiveView Try oApp.ScreenUpdating = False Dim oView As Inventor.View = oDoc.Views.Add() oView.Visible = False Dim oCamera As Camera = oView.Camera oCamera.ViewOrientationType = kIsoTopRightViewOrientation oCamera.Fit oCamera.ApplyWithoutTransition Dim oColor As Color= oApp.TransientObjects.CreateColor(255, 255, 255) Call oCamera.SaveAsBitmap(sPath & "\PDM_IMPORT\" & sFile & "\" & sFile & ".jpg", 1920, 1080, oColor) oView.Close Catch ex As Exception MsgBox(ex.Message) Finally oApp.ScreenUpdating = True End Try End Sub Private Sub SaveAsdxf(ByVal oDoc As Document) 'oDoc = ThisApplication.ActiveDocument Dim sPath As String = System.IO.Path.GetDirectoryName(oDoc.FullFileName) Dim sFile As String = System.IO.Path.GetFileName(oDoc.FullFileName) 'Prüfen ob Datei ein Blech ist und falls keine Abwicklnug vorhanden Abwicklung erstellen If oDoc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then oFlatPattern = oDoc.ComponentDefinition.FlatPattern oSheetMetalCompDef = oDoc.ComponentDefinition If oSheetMetalCompDef.HasFlatPattern = False Then oSheetMetalCompDef.Unfold Else 'Abbrechen, wenn kein Blechbauteil Exit Sub End If 'Export der Abwicklung durchführen Dim sOut As String sOut = "FLAT PATTERN DXF?AcadVersion=2004&OuterProfileLayer=WF_CUT&InteriorProfilesLayer=WF_CUT&InvisibleLayers=IV_FEATURE_PROFILES_DOWN;IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES" Dim sFname As String sFname = sPath & "\PDM_IMPORT\" & sFile & "\Abwicklung\" & sFile & ".dxf" System.IO.Directory.CreateDirectory (sPath & "\PDM_IMPORT\" & sFile & "\Abwicklung\") oSheetMetalCompDef.DataIO.WriteDataToFile(sOut,sFname) 'oDoc = ThisApplication.ActiveDocument Dim oSMDef As SheetMetalComponentDefinition oSMDef = oDoc.ComponentDefinition oSMDef.FlatPattern.ExitEdit Dim oCD As SheetMetalComponentDefinition oCD = oDoc.ComponentDefinition Dim oFP As FlatPattern oFP = oCD.FlatPattern Dim dimX, dimY, dimZ As Double Dim sdimXYZ As String dimX = Round((oFP.Body.RangeBox.MaxPoint.X - oFP.Body.RangeBox.MinPoint.X) * 10, 3) dimY = Round((oFP.Body.RangeBox.MaxPoint.Y - oFP.Body.RangeBox.MinPoint.Y) * 10, 3) dimZ = Round((oFP.Body.RangeBox.MaxPoint.Z - oFP.Body.RangeBox.MinPoint.Z) * 10, 3) 'Call IPropEintraege.Property_setzen(oDoc, "Groesse_Abwicklung", CStr(sdimXYZ)) Dim oParams As Inventor.Parameters oParams = oDoc.ComponentDefinition.Parameters 'Parameter löschen 'oParams.UserParameters.Item(GrenzeAbwicklungX).Delete 'oParams.UserParameters.Item(GrenzeAbwicklungY).Delete 'oParams.UserParameters.Item(GrenzeAbwicklungZ).Delete 'Parameter für Grenzen erstellen oParams.UserParameters.AddByValue ("GrenzeAbwicklungX", dimX / 10, kMillimeterLengthUnits) oParams.UserParameters.AddByValue ("GrenzeAbwicklungY", dimY / 10, kMillimeterLengthUnits) oParams.UserParameters.AddByValue("GrenzeAbwicklungZ", dimZ / 10, kMillimeterLengthUnits) MsgBox ("GrenzeAbwicklungZ", dimZ) oFP = Nothing oCD = Nothing oDoc = Nothing End Sub
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 01. Mrz. 2022 22:38 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Der Code erstellt auch Benutzerparameter und keine iProps. Vielleicht liegt es daran. Kannst ja bei den Parametern die ExposedAsProperty Eigenschaft auf True setzen, dann werden die Parameter als benutzerdef. iProp exportiert. Unter dem CustomPropertyFormat des Benutzerparameters kannst dann noch einstellen wie das Exportformat aussehen soll. Oder du erstellst direkt die iProps
Code:
iProperties.Value("Custom", "GrenzeAbwicklungX")= dimX / 10 iProperties.Value("Custom", "GrenzeAbwicklungY")= dimY / 10 iProperties.Value("Custom", "GrenzeAbwicklungZ")= dimZ / 10
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 02. Mrz. 2022 09:22 <-- editieren / zitieren --> Unities abgeben:
Hallo Ralf, ja das hätte ich auch verstehen können. Hab das mit deinem Code ausgetauscht, aber bei mir werden die Properties nur in der obersten Baugruppe angelegt. ------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 02. Mrz. 2022 17:10 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Hallo Achja, hatte vergessen dass es oben in einer Schleife durch alle Bauteile läuft. Der letzte Code schreibt nur die iProps in dem Dokument, in dem die Regel ausgeführt wird. Versuch es mal so: Code:
WriteProp(oDoc, "GrenzeAbwicklungX", dimX / 10) WriteProp(oDoc, "GrenzeAbwicklungY", dimY / 10) WriteProp(oDoc, "GrenzeAbwicklungZ", dimZ / 10)
Und noch diese Sub mit einfügen: Code:
Private Sub WriteProp(ByVal oDoc As Document, ByVal sPropName As String, ByVal dPropValue As Double) Dim oPropSet As PropertySet = oDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") Try oPropSet.Add(dPropValue,sPropName) Catch oPropSet.Item(sPropName).Value=dPropValue 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 |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 03. Mrz. 2022 12:13 <-- editieren / zitieren --> Unities abgeben:
|
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 02. Mai. 2022 12:35 <-- editieren / zitieren --> Unities abgeben:
Hallo, hier ist ein komischer Fehler aufgetreten, der sich bei ähnlichen Teilen wiederholt. Durch die nicht ganz perfekte Kontur (Verformung beim Biegen oder durch Kundenzeichnungen) stimmt der Z-Wert (Blechdicke) nicht mehr (24,8 anstatt 10). Dieser Wert ist aber wichtig, da wir damit automatisch das Laserteil erstellen, wenn der nicht stimmt haben wir ein Problem. Habt ihr dafür irgendeine Lösung? Hab das Teil angehängt. Die Extursionen in der Abwicklung beheben das Problem, aber ich möchte nicht alle Teile nachbearbeiten... Wie gesagt bearbeiten wir die Abwicklungen oft noch nach (Aufmaß o.ä.) und ich kann deshalb nicht die definierte Blechstärke verwenden. Danke für euer Hilfe.
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 02. Mai. 2022 16:15 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
|
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 02. Mai. 2022 16:37 <-- editieren / zitieren --> Unities abgeben:
Hallo KraBBy, war auch meine Vermutung. Ich hab mich schon an der OrientedMinimumRangeBox versucht, da bin ich programmiertechnisch aber zu schwach. (habs in der Abwicklung und in der Baugruppe nicht hingekriegt) Kann ich deshalb nicht beurteilen Trotzdem danke für die schnelle Antwort
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 03. Mai. 2022 09:06 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Moin Da die Abwicklung nicht verdreht im Koordinatensystem liegt, wird die OrientedRangeBox in Z-Richtung vermutlich kaum andere Werte liefern. Solche Importteile verursachen gern Probleme. Die verwundenen Flächen und die fehlende Eckfreistellung an den Biegungsenden ... wundert mich das Inventor das überhaupt abwickelt. Ich würde im Biegungsteil alle Seitenflächen und die Flächen der Unterseite (ohne Korrektur) löschen. Anschließend mit Verdickung/Versatz wieder aufdicken. Dann hast du in der Abwicklung schonmal lotrecht stehende Seitenflächen. Hilft aber bei diesem Modell nicht bei der angeblichen Blechdicke laut RangeBox. Da ist noch irgendwas das die RangeBox aufweitet. Ich konnte es auch nicht finden. Da in einer Blechabwicklung normalerweise Ober- und Unterseite planparallel verlaufen und ein Blech keine variierende Dicke hat, probiers mal ganz einfach mit: Code:
Dim oPartDoc As PartDocument = ThisDoc.Document Dim oCompDef As SheetMetalComponentDefinition = oPartDoc.ComponentDefinition 'Get minimum distance between flat pattern top and bottom face (distance is in database unist "cm") Dim dDist As Double = ThisApplication.MeasureTools.GetMinimumDistance(oCompDef.FlatPattern.TopFace, oCompDef.FlatPattern.BottomFace) 'Convert distance to "mm" dDist = oPartDoc.UnitsOfMeasure.ConvertUnits(dDist, UnitsTypeEnum.kDatabaseLengthUnits, UnitsTypeEnum.kMillimeterLengthUnits) 'Display distance MsgBox(dDist & " mm",MsgBoxStyle.Information,"iLogic GetMinimumDistance")
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 03. Mai. 2022 12:10 <-- editieren / zitieren --> Unities abgeben:
Hallo, ja das könnte gehen. Hab es mit den Code unten getestet, der funktioniert auch. Wenn ich aber in der Baugruppe speichere, wird die Regel nicht ausgeführt (hab als Trigger nach öffnen von Dokument und vor dem Speichern von Dokument beim Bauteil) Was mach ich falsch? Code: Sub Main oDoc = ThisApplication.ActiveDocument ' Get the current Part document. Dim partDoc As PartDocument = ThisDoc.Document' Get surface body to measure (assume it's the first body). Dim body1 As SurfaceBody = partDoc.ComponentDefinition.SurfaceBodies.Item(1) ' Get the oriented mininum range box of the body. ' NOTE: "OrientedMinimumRangeBox" was added in Inventor 2020.3/2021. Dim minBox As OrientedBox = body1.OrientedMinimumRangeBox ' Get length of each side of mininum range box. Dim dir1 As Double = minBox.DirectionOne.Length Dim dir2 As Double = minBox.DirectionTwo.Length Dim dir3 As Double = minBox.DirectionThree.Length ' Convert lengths to document's length units. Dim uom As UnitsOfMeasure = partDoc.UnitsOfMeasure dir1 = uom.ConvertUnits(dir1, "mm", uom.LengthUnits)*10 dir2 = uom.ConvertUnits(dir2, "mm", uom.LengthUnits)*10 dir3 = uom.ConvertUnits(dir3, "mm", uom.LengthUnits)*10 ' Sort lengths from smallest to largest. Dim lengths As New List(Of Double) From {dir1, dir2, dir3 } lengths.Sort Dim minLength As Double = lengths(0) Dim midLength As Double = lengths(1) Dim maxLength As Double = lengths(2) ' Display minimum rangebox size. 'MessageBox.Show("Oriented Minimum Rangebox Size: " & ' minLength.ToString("#.###") & " x " & midLength.ToString("#.###") & " x " & maxLength.ToString("#.###"), ' "Oriented Minimum Rangebox", MessageBoxButtons.OK, MessageBoxIcon.Information) iProperties.Value("Custom", "Länge")= (Round(lengths(0),2)) iProperties.Value("Custom", "Breite")= (Round(lengths(1),2)) iProperties.Value("Custom", "Höhe")= (Round(lengths(2),2)) iProperties.Value("Custom", "Fläche")=(Round(iProperties.Area, 2)) 'Prüfen ob Datei ein Blech ist und falls keine Abwicklnug vorhanden Abwicklung erstellen oDoc = ThisApplication.ActiveDocument If oDoc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then oFlatPattern = oDoc.ComponentDefinition.FlatPattern oSheetMetalCompDef = oDoc.ComponentDefinition If oSheetMetalCompDef.HasFlatPattern = False Then oSheetMetalCompDef.Unfold Else 'Abbrechen, wenn kein Blechbauteil Exit Sub End If oDoc = ThisApplication.ActiveDocument Dim oSMDef As SheetMetalComponentDefinition oSMDef = oDoc.ComponentDefinition oSMDef.FlatPattern.ExitEdit Dim oCD As SheetMetalComponentDefinition oCD = oDoc.ComponentDefinition Dim oFP As FlatPattern oFP = oCD.FlatPattern Dim dimX, dimY, dimZ As Double Dim sdimXYZ As String dimX = Round((oFP.Body.RangeBox.MaxPoint.X - oFP.Body.RangeBox.MinPoint.X) * 10, 3) dimY = Round((oFP.Body.RangeBox.MaxPoint.Y - oFP.Body.RangeBox.MinPoint.Y) * 10, 3) dimZ = Round((oFP.Body.RangeBox.MaxPoint.Z - oFP.Body.RangeBox.MinPoint.Z) * 10, 3) iProperties.Value("Custom", "AbwicklungX")= dimX iProperties.Value("Custom", "AbwicklungY")= dimY oFP = Nothing oCD = Nothing oDoc = Nothing Dim oPartDoc As PartDocument = ThisApplication.ActiveDocument Dim oPpartDoc As PartDocument = ThisDoc.Document Dim oCompDef As SheetMetalComponentDefinition = oPartDoc.ComponentDefinition 'Get minimum distance between flat pattern top and bottom face (distance is in database unist "cm") Dim dDist As Double = ThisApplication.MeasureTools.GetMinimumDistance(oCompDef.FlatPattern.TopFace, oCompDef.FlatPattern.BottomFace) 'Convert distance to "mm" dDist = oPartDoc.UnitsOfMeasure.ConvertUnits(dDist, UnitsTypeEnum.kDatabaseLengthUnits, UnitsTypeEnum.kMillimeterLengthUnits) 'Display distance iProperties.Value("Custom", "Blechdicke")= dDist
End Sub
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 03. Mai. 2022 12:15 <-- editieren / zitieren --> Unities abgeben:
|
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 03. Mai. 2022 13:41 <-- editieren / zitieren --> Unities abgeben: Nur für HansPeterNew
Ohne mir das genauer angesehen zu haben (von ausprobieren ganz zu schweigen), könnte es an Code: oDoc = ThisApplication.ActiveDocument
liegen. Das kommt mehrmals vor. Beim Auslösen der Regel aus einer Bgr. heraus, ist diese Bgr. das aktive Dokument. Oben wird auch Code: ThisDoc.Document
verwendet, das sollte das Einzelteil, das gerade gespeichert wird, liefern (ganz sicher bin ich mir aber nicht). Mit einer MsgBox ganz zu Beginn der Regel, könntest Du ausprobieren, ob sie tatsächlich nicht ausgeführt wird (oder nur still abbricht). ------------------ Gruß KraBBy Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
HansPeterNew Mitglied Technisches Büro
Beiträge: 45 Registriert: 19.10.2021
|
erstellt am: 03. Mai. 2022 16:11 <-- editieren / zitieren --> Unities abgeben:
Hallo, vielen Dank. Habs ersetzt, jetzt funkt´s. Werde das jetzt auch mal ausgiebig testen und evt. melde ich mich nochmal. Nochmal Kompliment: dieses Forum und die Antworten hier sind wirklich Spitze
------------------ Beste Grüße Hans Peter Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |