| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte | | | | Request a special discount on NVIDIA RTX 5000 Ada Generation GPU !, eine Pressemitteilung
|
Autor
|
Thema: Step Baugruppe für DXF in Blechteile konvertieren (1255 / mal gelesen)
|
minimal Mitglied Konstrukteur
Beiträge: 1 Registriert: 15.06.2021 Inventor 2020; WIN7
|
erstellt am: 15. Jun. 2021 15:41 <-- editieren / zitieren --> Unities abgeben:
Moin moin Leutz, ich habe mal eine Frage zur Inventorsteuerung via VBA.. Gegeben ist folgender Sachverhalt: (Inventor 2020 Professional / Win7) Ich bekomme eine Step - Baugruppe (Siehe Anhang) und benötige von jedem darin enthaltenen Volumenkörper eine DXF. Meine Aufgabe besteht darin, jeden Volumenkörper aus der Baugruppe in ein Blechteil zu konvertieren. Dies geht leider nur (meines Wissens nach), indem ich für jeden Volumenkörper eine Basisfläche definiere. Jedem Volumenkörper die Basisfläche zuzuordnen kann äußerst Umfangreich sein umso komplexer die Step – Baugruppe ist… Nun meine Frage: Gibt es via VBA eine Möglichkeit die Basisfläche (Ich nehme mal an das es die Fläche eine Körpers mit dem größten Flächeninhalt ist..?!) automatisch jedem Volumenkörper zuzuordnen um dann automatisch eine Abwicklung / DXF erstellen zu können? Also quasi ein „ multi DXF erstellen aus einer Step – Baugruppe“.. Bin euch über jede Idee / Vorschlag dankbar.
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 720 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 15. Jun. 2021 17:45 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
|
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 16. Jun. 2021 07:27 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hallo zusammen, [/Halb OT on] immer wieder schön zu sehen was für tolle Vorlagen die Jungs (und Mädels?) von Mod the machine für uns erstellen. [/Halb OT off] Grüße
EIBe 3D Edit 1: @minimal: Willkommen im Forum
[Diese Nachricht wurde von EIBe 3D am 16. Jun. 2021 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 720 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 16. Jun. 2021 09:15 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Die genannte Lösung von Mod the machine konnte ich nun für Deine Anwendung etwas aufbohren. Ich hab meinen "Abwicklungs-Export" ergänzt und eine Logik zum Öffnen einer beliebigen Stp. Im einfachsten Fall ist es damit eine 1-Klick-Lösung, wenn Du vorher den Pfad der step-Datei in die Zwischenablage von Windows kopiert hast. Bei Win7 im Dateiexplorer: Umschalt + rechte Maustaste -> als Pfad kopieren Dann das Sub ConvertToSheetMetal_Main aufrufen. Einige weitere Gedanken als Kommentare im Code... Code: Option ExplicitConst sPfad As String = "C:\temp\bla\" 'Ablagepfad für dxf; muss existieren sonst Fehler Private gsFertigMsg As String 'verwendet für Schlussmeldung '---------------- ' https://modthemachine.typepad.com/my_weblog/2020/09/generate-flat-pattern-for-3d-sheet-metal-files.html ' leicht angepasst (ausgehend vom Import einer Bgr (statt Einzelteil) und dann Schleife durch alle Einzelteile) Sub ConvertToSheetMetal_Main()
Dim path As String: path = "C:\temp\6000-BT-2x.stp" 'Dateiname einer beliebigen STEP path = get_StpFile_Clipboard_or_Dialog If "" = path Then Exit Sub 'z.b. falls der Öffnen-Dialog abgebrochen wurde Dim asmDoc As AssemblyDocument Set asmDoc = ThisApplication.Documents.Open(path) 'hier wird ein Fehler auftreten, wenn das Step keine Bgr. enthält! 'Variable auf Modulebene für Schlussmeldung vorbereiten (befüllt im dxfExp.) gsFertigMsg = "in diesem Verzeichnis" & vbCrLf gsFertigMsg = gsFertigMsg & vbTab & sPfad & vbCrLf gsFertigMsg = gsFertigMsg & "wurden folgende Dateien erzeugt: " & vbCrLf & vbCrLf 'es wäre vmtl. noch gut den folgenden Ablauf in eine einzige Rückgängig-Aktion zu packen Dim oTxnMgr As TransactionManager '... [fehlt] 'Schleife durch alle Dokumente, der aktiven Bgr Dim tmpDoc As Document, doc As PartDocument For Each tmpDoc In asmDoc.AllReferencedDocuments 'asmDoc.ReferencedDocuments liefert nur die Unterbgr. If TypeOf tmpDoc Is PartDocument Then '### Displayupdate ausschalten, dann sollte es etwas schneller laufen 'ThisApplication.ScreenUpdating = False 'erst wenn es ausreichend gut läuft...! Set doc = tmpDoc 'Aufruf des Sub für das einzelne Bauteil Call ConvertToSheetMetal(doc) ThisApplication.ScreenUpdating = True 'Export vom dxf der Abwicklung Dim sDateiName As String sDateiName = Left(doc.DisplayName, Len(doc.DisplayName) - 4) 'Dateiname ohne Endung (.ipt) Call WriteSheetMetalDXF(sPfad, sDateiName, doc) Else 'kein part 'nix zu tun End If Next 'Schlussmeldung MsgBox gsFertigMsg, vbOKOnly, "Fertig" End Sub Sub ConvertToSheetMetal(doc As PartDocument) ' Turn it into a sheet metal part doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Dim cd As SheetMetalComponentDefinition Set cd = doc.ComponentDefinition cd.UseSheetMetalStyleThickness = False cd.Thickness.Value = GetThickness(cd.SurfaceBodies(1)) Call cd.Unfold '### das Bauteil wird in neuem View geöffnet, wieder schließen (sonst schlägt das nächste Unfold fehl) cd.FlatPattern.ExitEdit If ThisApplication.ActiveView.Document Is doc Then ThisApplication.ActiveView.Close End Sub Function GetThickness(sb As SurfaceBody) As Double ' unverändert [KraBBy] ' Find biggest face Dim f As Face Dim bf As Face Dim area As Double For Each f In sb.Faces ' Only care about planar faces If TypeOf f.Geometry Is Plane And f.Evaluator.area > area Then Set bf = f area = f.Evaluator.area End If Next ' Find the opposite face Dim p As Plane Set p = bf.Geometry Dim pt1 As Point Set pt1 = bf.PointOnFace Dim tr As TransientGeometry Set tr = ThisApplication.TransientGeometry Dim objs As ObjectsEnumerator Dim pts As ObjectsEnumerator Dim n As UnitVector ' We have to search in the opposite direction ' of the face's normal vector If bf.IsParamReversed Then Set n = p.Normal Else Set n = tr.CreateUnitVector( _ -p.Normal.x, -p.Normal.y, -p.Normal.z) End If ' objs(2) should be the opposite face ' but we do not need it, the intersection point ' is enough, i.e. pts(2) Call sb.FindUsingRay(pt1, n, 0, objs, pts) ' The first point found will be on the same face ' The second one will be on the face opposite Dim pt2 As Point Set pt2 = pts(2) GetThickness = pt1.DistanceTo(pt2) End Function Sub TestFlatPattern() ' nicht implementiert Dim doc As PartDocument Set doc = ThisApplication.ActiveDocument Dim cd As SheetMetalComponentDefinition Set cd = doc.ComponentDefinition Dim tr As TransientBRep Set tr = ThisApplication.TransientBRep Dim objs As ObjectCollection Set objs = ThisApplication.TransientObjects.CreateObjectCollection Call objs.Add(cd.SurfaceBodies(1)) Call objs.Add(cd.FlatPattern.SurfaceBodies(1)) Set objs = tr.GetIdenticalBodies(objs) If objs.Count > 0 Then MsgBox ("The flat pattern body is the same as the original body") End If End Sub
'######################## Public Sub WriteSheetMetalDXF(sPfad As String, sDatName As String, Optional oDoc As Document) ' bildet den Befehl ab ' Abwicklung -> Kopie speichern unter -> dxf ... ' KraBBy 18.03.2015 '
On Error GoTo ErrHnd ' Make sure the document is a sheet metal document. If Not (oDoc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}") Then MsgBox "Das ref. Dokument ist kein Blechteil!" & vbCrLf _ & oDoc.DisplayName, vbInformation + vbOKOnly, "no Sheet Metal" Exit Sub End If ' Get the sheet metal component definition. Because this is a part document whose ' sub type is sheet metal, the document will return a SheetMetalComponentDefinition ' instead of a PartComponentDefinition. Dim oSheetMetalCompDef As SheetMetalComponentDefinition Set oSheetMetalCompDef = oDoc.ComponentDefinition Dim oFlat As FlatPattern Set oFlat = oSheetMetalCompDef.FlatPattern If oFlat Is Nothing Then 'keine Abwicklung 'Block hinzu 26.06.2018 oSheetMetalCompDef.Unfold 'Abwicklung erzeugen 'es gibt auch die Methode Unfold2, dann mit Angabe der "Basisfläche" Set oFlat = oSheetMetalCompDef.FlatPattern End If If oFlat Is Nothing Then 'erneute Prüfung 'Abwicklung konnte auch nicht erzeugt werden MsgBox "Das ref. Dokument enthält keine Abwicklung!" & vbCrLf _ & oDoc.DisplayName, vbInformation + vbOKOnly, "no Flat" Exit Sub End If 'Get the DataIO object. Dim oDataIO As DataIO Set oDataIO = oDoc.ComponentDefinition.DataIO ' Build the string that defines the format of the DXF file. ' Parameter aus Hilfe zu DataIO Interface Dim sOut As String sOut = "FLAT PATTERN DXF?" sOut = sOut & "AcadVersion=R12" '2010, 2007, 2004, 2000, or R12 sOut = sOut & "&OuterProfileLayer=IV_outer" sOut = sOut & "&InteriorProfilesLayer=IV_inner" sOut = sOut & "&FeatureProfilesLayer=IV_Profiles" sOut = sOut & "&TangentLayer=IV_Tangent" 'sOut = sOut & "&BendLayer=IV_Bend" 'Alternativ zu BendUp/-Down sOut = sOut & "&BendUpLayer=IV_BendUp" sOut = sOut & "&BendDownLayer=IV_BendDown" sOut = sOut & "&ToolCenterLayer=IV_ToolCenter" sOut = sOut & "&ArcCentersLayer=IV_ArcCenter" 'sOut = sOut & "&SimplifySplines=True" 'auskom.; ansonsten Fehler beim Export !?! 25.06.2018 'sOut = sOut & "&SplineTolerance=0.01" 'auskom.; -"- sOut = sOut & "&TangentLayerColor=255;0;0" 'Beispiel Farbeinstellung (RGB) sOut = sOut & "&InvisibleLayers=IV_ArcCenter" 'hier aufgelistete Layer (getrennt durch ";"), werden nicht exportiert 'Datei bereits vorhanden? Dim sFileName As String sFileName = sPfad & sDatName 'ohne Dateiendung! If Not ("" = Dir(sFileName & ".dxf")) Then 'Datei existiert Dim vInput vInput = MsgBox(sFileName & ".dxf" & vbCrLf & "Datei existiert bereits!" & vbCrLf _ & "Überschreiben?", vbYesNoCancel + vbExclamation, "Datei existiert bereits") If vbYes = vInput Then Kill sFileName & ".dxf" 'existierende Datei löschen ElseIf vbNo = vInput Then Dim iCount As Integer iCount = 0 Do sFileName = sFileName & "_" 'Dateiname ändern sDatName = sDatName & "_" 'auch hier ändern damit gsFertigMsg passt iCount = iCount + 1 If 5 < iCount Then 'Endlosschleife verhindern MsgBox "Kein DXF erzeugt!" & vbCrLf & "es existieren bereits mehrere Dateien mit diesem Dateinamen (und angehängtem '_')" _ , vbCritical, "jetzt is aber mal gut!" Exit Sub End If Loop Until "" = Dir(sFileName & ".dxf") Else 'Cancel gedrückt oder MsgBox geschlossen (oben rechts) MsgBox "Kein DXF erzeugt!", vbOKOnly, "Abbruch durch Benutzer" Exit Sub End If End If ' Create the DXF file. oDataIO.WriteDataToFile sOut, sFileName & ".dxf" 'Schlussmeldung 'MsgBox "Export erfolgt" & vbCrLf & sFilename & ".dxf", vbInformation, "DXF (Flat) Fertig" gsFertigMsg = gsFertigMsg & sDatName & ".dxf" & vbCrLf 'Aufräumen Set oSheetMetalCompDef = Nothing Set oFlat = Nothing Set oDataIO = Nothing Exit Sub ErrHnd: MsgBox "Fehler in Sub 'WriteSheetMetalDXF': " & vbCrLf & vbCrLf & Err.Description, vbCritical, "Err.Number: " & Err.Number End Sub Private Function get_StpFile_Clipboard_or_Dialog() As String ' Pfad aus der Zwischenablage nehmen (Prüfung ob Datei vorhanden, auch Dateiendung) ' sonst OpenDialog
'Titel für Msgbox(en) Dim sMsgTitle As String sMsgTitle = "Makro 'Import_stp'" 'Win-Zwischenablage auswerten Dim sFile As String, bFileDiag As Boolean sFile = txt_FromClipboard() sFile = Replace$(sFile, Chr(34), "") 'Anführungszeichen ggf. entfernen If "" = sFile Then 'kein Text in Zwischenablage bFileDiag = True ElseIf Not Test_FileExists(sFile) Then ' "" = Dir$(sFile) Then 'Dir() liefert bei manchen Inputs einen Fehler 'es ist kein Pfad oder Datei existiert nicht bFileDiag = True ElseIf ".stp" = LCase$(Right$(sFile, 4)) Or ".step" = LCase$(Right$(sFile, 5)) Then 'die Datei existiert und hat die richtige Dateiendung 'kein Dialog erforderlich bFileDiag = False Else 'Datei existiert, hat aber nicht die richtige Dateiendung MsgBox "In der Zwischenablage ist folgende Datei angegeben:" & vbCrLf _ & sFile & String(2, vbCrLf) _ & "Dieses Makro funktioniert aber nur für .stp (.step)", vbInformation + vbOKOnly, sMsgTitle & " - abgebrochen" Exit Function End If 'Öffnen-Dialog If bFileDiag Then Dim oFileDlg As Inventor.FileDialog Call ThisApplication.CreateFileDialog(oFileDlg) 'oFileDlg.InitialDirectory = FileSystem.getPathName(???) 'was könnte ein sinnvolles Verz. sein? oFileDlg.DialogTitle = sMsgTitle & " - Datei für Import angeben" oFileDlg.filter = "STEP Files (*.stp;*.step)|*.stp;*.step|All Files (*.*)|*.*" oFileDlg.FilterIndex = 1 oFileDlg.CancelError = False 'On Error Resume Next oFileDlg.ShowOpen If "" = oFileDlg.Filename Then MsgBox "Aktion abgebrochen.", vbOKOnly, "nichts passiert" Exit Function Else sFile = oFileDlg.Filename End If Set oFileDlg = Nothing Else: 'nix, unten weiter (sFile schon aus Zwischenablage gesetzt End If 'sFile ist nun mit Pfad/Dateiname einer stp/STEP befüllt (oder das Makro wurde abgebrochen) '-> Rückgabewert der Fkt get_StpFile_Clipboard_or_Dialog = sFile Set oFileDlg = Nothing End Function Private Function txt_FromClipboard() As String 'gibt den Text aus der Zwischenablage von Windows zurück 'Rückgabe "", wenn kein Text in Zwischenablage
Dim o As DataObject Set o = New DataObject o.GetFromClipboard On Error Resume Next txt_FromClipboard = o.GetText(1) 'Rückgabewert If Not 0 = Err.Number Then 'wenn etwas anderes als Text in der ZwAblage ist, schlägt obige Z. fehl On Error GoTo 0 txt_FromClipboard = "" End If Set o = Nothing End Function Public Function Test_FileExists(sFile As String) As Boolean ' existiert Datei? ' Rückgabewert True: Datei existiert On Error GoTo err_handler Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") If fs.FileExists(sFile) Then 'MsgBox "Datei existiert nicht", vbInformation, "Fehler in 'FileExists'" Test_FileExists = True Else Test_FileExists = False End If Set fs = Nothing Exit Function err_handler: MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Fehler im Funktion 'FileExists'" End Function
------------------ Gruß KraBBy Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 17. Jun. 2021 15:35 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hübsch, hübsch zu beachten wäre noch eine Abfrage ob es sich um ein multibody part handelt. Bei Step-Importen nicht unüblich. Dort läuft "Call cd.Unfold" in einen Fehler. Ich meine seit irgendeiner Version wurden die Abwicklungen für multibody parts aber unterstützt dort sollte es klappen. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 720 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 17. Jun. 2021 17:02 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hi EIBe 3D, ist schon berücksichtigt Zumindest tritt vorher schon ein Fehler auf. Zitat: [...] Dim asmDoc As AssemblyDocument Set asmDoc = ThisApplication.Documents.Open(path) 'hier wird ein Fehler auftreten, wenn das Step keine Bgr. enthält! [...]
Wenn die Logik auf für multibody parts (MBP) funktionieren soll, wird man noch an ein par mehr Schrauben drehen müssen. Mehrere Abwicklungen klappen darin ja nicht (oder?). Dh. man könnte evtl. die ganzen Blechstile mit den unterschiedlichen Dicken im MBP verwalten, bräuchte aber für die Abwicklung wieder eine AK (abgeleitete Komponente) von jedem Einzelteil. Die Anpassung am Makro wäre kleiner, wenn man nur auf das Öffnen der STEP verzichtet und mit der geöffneten Baugruppe loslegt und diese eben vorher (von Hand per AK) erzeugt. Da fällt mir ein: in diesem Fall/Beispiel ist ein MBP vielleicht nicht üblich/sinnvoll. Da ginge ja die Info bzgl. Gleichteilen verloren, weil jedes an einer anderen Stelle im Raum sitzt. Im Beispiel waren gleiche Teile mehrmals verbaut (jetzt aus dem Kopf, ohne es nochmal geöffnet zu haben). ------------------ Gruß KraBBy Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 18. Jun. 2021 09:06 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Morgen, zugegeben das Beispiel habe ich mir bis eben nicht angesehen. Da ich zufällig aber gerade einen ähnlichen Fall zur Untersuchung reinbekommen habe, fiel mir auf das einige, aus Step erzeugte Bauteile, als MBPs daher kommen. Diese liegen hier innerhalb der BG-Struktur vor. Ich schließe MBPs von vornherein aus der Konvertierung aus. Die Vorraussetzungen bei meiner Import-Step und Anforderungen sind aber auch andere. Was mir nun beim Vergleich des Beispiels von minimal und meinem aufgefallen ist: In seinem sind Gleichteile vorhanden, bei mir hat jede Kopie einer Komponente einen eigenen Bauteilnamen enthalten. Schlecht in meinem Fall. Auch eine mittlere Herausforderung ist das sinnvolle Herausfiltern von ungefalteten Blechen (bspw. Flanschplatte) wenn ich eine Kontrolle auf Abwicklungskörper ungleich Ursprungskörper ähnlich wie im verlinkten Beispiel durchführe (ähnlich weil Code: GetIdenticalBodies(objs)
erst in INV2021 eingeführt wurde). Hier mal meine aktuelle Abfrage dazu:
Code:
Private Function TestFlatPattern() As Boolean Dim doc As PartDocument Set doc = ThisApplication.ActiveDocument Dim equalBody As Boolean Dim cd As SheetMetalComponentDefinition Set cd = doc.ComponentDefinition Dim oSurfaceBody01 As Inventor.SurfaceBody, oSurfaceBody02 As Inventor.SurfaceBody Set oSurfaceBody01 = cd.SurfaceBodies(1) Set oSurfaceBody02 = cd.FlatPattern.SurfaceBodies(1) Dim oFaces01 As Inventor.Faces, oFaces02 As Inventor.Faces Set oFaces01 = oSurfaceBody01.Faces Set oFaces02 = oSurfaceBody02.Faces Dim oEdges01 As Inventor.Edges, oEdges02 As Inventor.Edges Set oEdges01 = oSurfaceBody01.Edges Set oEdges02 = oSurfaceBody02.Edges Dim baseFace As Inventor.face Set baseFace = cd.FlatPattern.baseFace If oFaces01.Count = oFaces02.Count Then If oEdges01.Count = oEdges02.Count Then equalBody = True End If End If TestFlatPattern = True If equalBody Then If Not isFlatSheet(oSurfaceBody01, baseFace) Then TestFlatPattern = False End If ' MsgBox TestFlatPattern End FunctionPrivate Function isFlatSheet(SurfaceBody As SurfaceBody, baseFace As face) As Boolean '(SurfaceBody As SurfaceBody) As Boolean Dim baseCounterFace As face ' Find the opposite face Dim Plane As Plane Set Plane = baseFace.Geometry Dim pt1 As Point Set pt1 = baseFace.PointOnFace Dim tr As TransientGeometry Set tr = ThisApplication.TransientGeometry Dim objs As ObjectsEnumerator Dim pts As ObjectsEnumerator Dim n As UnitVector ' We have to search in the opposite direction ' of the face's normal vector If baseFace.IsParamReversed Then Set n = Plane.Normal Else Set n = tr.CreateUnitVector( _ -Plane.Normal.x, -Plane.Normal.y, -Plane.Normal.Z) End If ' objs(2) should be the opposite face Call SurfaceBody.FindUsingRay(pt1, n, 0, objs, pts) Set baseCounterFace = objs(2) If Round(baseFace.Evaluator.area, 5) = Round(baseCounterFace.Evaluator.area, 5) Then isFlatSheet = True End Function
Mein Vergleich geht davon aus, dass sich bei einem entfalteten Blech die Anzahl der Flächen und Kanten ändern muss damit nicht die gleiche Geometrie vorliegt. Dann könnte es aber immer noch ein ungefaltetes Blechteil oder eine sonstige beliebige Geometrie sein. Hat die Gegenfläche der Basisfläche jedoch den gleichen Flächeninhalt gehe ich davon aus, dass es sich wohl um ein ungefaltetes Blechteil handeln muss. Ist beides nicht der Fall gibt TestFlatPattern False zurück und über ein UndoTransaction mache ich die gesamte Konvertiererei rückgängig. Bisherige Tests bestätigen recht hohe Wirksamkeit Grüße EIB 3D
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 18. Jun. 2021 09:40 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Zitat: Bisherige Tests bestätigen recht hohe Wirksamkeit
Kaum geschrieben schon einen Fall gehabt wo es nciht passt :D Änderungen:
Code:
Private Function TestFlatPattern() As Boolean Dim doc As PartDocument Set doc = ThisApplication.ActiveDocument Dim equalBody As Boolean Dim cd As SheetMetalComponentDefinition Set cd = doc.ComponentDefinition Dim oSurfaceBody01 As Inventor.SurfaceBody, oSurfaceBody02 As Inventor.SurfaceBody Set oSurfaceBody01 = cd.SurfaceBodies(1) Set oSurfaceBody02 = cd.FlatPattern.SurfaceBodies(1) Dim oFaces01 As Inventor.Faces, oFaces02 As Inventor.Faces Set oFaces01 = oSurfaceBody01.Faces Set oFaces02 = oSurfaceBody02.Faces Dim oEdges01 As Inventor.Edges, oEdges02 As Inventor.Edges Set oEdges01 = oSurfaceBody01.Edges Set oEdges02 = oSurfaceBody02.Edges Dim MinPointX As Double, MinPointY As Double, MinPointZ As Double Dim MaxPointX As Double, MaxPointY As Double, MaxPointZ As Double Dim dx As Double, dy As Double, dz As Double MinPointX = oSurfaceBody02.RangeBox.MinPoint.x: MinPointY = oSurfaceBody02.RangeBox.MinPoint.y: MinPointZ = oSurfaceBody02.RangeBox.MinPoint.Z MaxPointX = oSurfaceBody02.RangeBox.MaxPoint.x: MaxPointY = oSurfaceBody02.RangeBox.MaxPoint.y: MaxPointZ = oSurfaceBody02.RangeBox.MaxPoint.Z dx = MaxPointX - MinPointX: dy = MaxPointY - MinPointY: dz = MaxPointZ - MinPointZ dx = Round(dx, 3): dy = Round(dy, 3): dz = Round(dz, 3): Dim thickness As Double thickness = Round(cd.thickness.value, 3) Dim baseFace As Inventor.face Set baseFace = cd.FlatPattern.baseFace If oFaces01.Count = oFaces02.Count Then If oEdges01.Count = oEdges02.Count Then equalBody = True End If End If TestFlatPattern = True If equalBody Then If Not isFlatSheet(oSurfaceBody01, baseFace) Then TestFlatPattern = False Else If Not dx = thickness Or Not dy = thickness Or Not dz = thickness Then TestFlatPattern = False End If End If ' MsgBox TestFlatPattern End Function
Um Abfrage ergänz, dass die Ausdehnung des Abgewickelten Bauteils in mindestens einer Koordinatenrichtung der zugewiesenen Blechdicke entsprechen muss. Liefert zwar auch noch in ungünstigen Fällen falsch positiv zurück, aber immerhin besser wie vorher. Edit1: Fehler beseitigt [Diese Nachricht wurde von EIBe 3D am 18. Jun. 2021 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
gunni0815 Mitglied Maschinenbau Techniker
Beiträge: 42 Registriert: 23.04.2014
|
erstellt am: 06. Jul. 2021 07:42 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hi Leutz, sorry für die verspätete Antwort. Ihr habt mir echt sehr weitergeholfen und ich habe mein Makro endlich fertig. Zu erwähnen sei noch, dass ich absolut neu im Umgang mit VBA bzw. im Allgemeinen mit der Makroprogrammierung bin. Ich gelobe Besserung und versuche "Am Ball" zu bleiben... Ohne die Hilfe unseres IT Spezialisten wäre ich niemals zu diesem Ergebnis gekommen.. Aus diesem Grund nochmal ein Special THX an unseren T.M. - du bist einfach der Beste.. <3 So, nun genug beweihräuchert und ab zum Wesentlichen.. Da die Preiskalkulation der Laserteile in einer separaten Excel Tabelle durchführt wird, reicht mit eine Textdatei, in der die gewünschten Teileinformationen stehen, die ich zur Preiskalkulation benötige. Hier mein Code: ---------------------------------------------------------------- Dim arrSL As Variant Dim oBom As BOM Function GetThickness(sb As SurfaceBody) As Double ' Find biggest face Dim f As Face Dim bf As Face Dim area As Double For Each f In sb.Faces ' Only care about planar faces If TypeOf f.Geometry Is Plane And f.Evaluator.area > area Then Set bf = f area = f.Evaluator.area End If Next ' Find the opposite face Dim p As Plane Set p = bf.Geometry Dim pt1 As Point Set pt1 = bf.PointOnFace Dim tr As TransientGeometry Set tr = ThisApplication.TransientGeometry Dim objs As ObjectsEnumerator Dim pts As ObjectsEnumerator Dim n As UnitVector ' We have to search in the opposite direction ' of the face's normal vector If bf.IsParamReversed Then Set n = p.Normal Else Set n = tr.CreateUnitVector( _ -p.Normal.X, -p.Normal.Y, -p.Normal.Z) End If ' objs(2) should be the opposite face ' but we do not need it, the intersection point ' is enough, i.e. pts(2) Call sb.FindUsingRay(pt1, n, 0, objs, pts) ' The first point found will be on the same face ' The second one will be on the face opposite Dim pt2 As Point Set pt2 = pts(2) GetThickness = pt1.DistanceTo(pt2) End Function Function PDFExport() 'Set a reference to the active document (the document to be published). Dim oDocument As Document ThisApplication.ActiveDocument.Update Set oDocument = ThisApplication.ActiveDocument Dim fso As Object Set fso = CreateObject("Scripting.FilesystemObject") Dim ret As Variant Dim dDoc As Document Set dDoc = ThisApplication.ActiveDocument If dDoc.FullFileName = "" Then MsgBox "Bitte zuerst die Datei speichern... " Exit Function End If ' Get the PDF translator Add-In. Dim PDFAddIn As TranslatorAddIn Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}") Dim oContext As TranslationContext Set oContext = ThisApplication.TransientObjects.CreateTranslationContext oContext.Type = kFileBrowseIOMechanism ' Create a NameValueMap object Dim oOptions As NameValueMap Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap ' Create a DataMedium object Dim oDataMedium As DataMedium Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium ' Check whether the translator has 'SaveCopyAs' options If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then 'oOptions.Value("All_Color_AS_Black") = 0 'oOptions.Value("Remove_Line_Weights") = 0 'oOptions.Value("Vector_Resolution") = 400 oOptions.Value("Sheet_Range") = kPrintAllSheets 'oOptions.Value("Custom_Begin_Sheet") = 2 'oOptions.Value("Custom_End_Sheet") = 4 'Set the destination file name Dim pfad As String pfad = fso.GetParentFoldername(dDoc.FullFileName) + "\pdf\" If Not fso.FolderExists(pfad) Then fso.CreateFolder pfad oDataMedium.FileName = Replace(pfad + dDoc.DisplayName, ".ipt", ".pdf") End If 'Publish document. Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium) 'MsgBox "PDF wurde unter -- C:\GAIN\Exchange -- gespeichert!!" End Function Private Function dxferzeugen(doc As PartDocument)
Dim DocFlatPattern As FlatPattern Dim tmpstr As String Dim pfad As String Dim dxfFileName As String Dim filesystem As Object Set filesystem = CreateObject("Scripting.FilesystemObject") pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\dxf\" If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad 'Debug.Print "start 1" Debug.Print doc.FullDocumentName Debug.Print "start" dxfFileName = Replace(pfad + doc.DisplayName, ".ipt", ".dxf") Dim oDataIO As DataIO Set oDataIO = doc.ComponentDefinition.DataIO Dim sOut As String sOut = "FLAT PATTERN DXF?" sOut = sOut & "AcadVersion=2004" '2010, 2007, 2004, 2000, or R12 sOut = sOut & "&OuterProfileLayer=IV_Outer_Profile" sOut = sOut & "&InteriorProfilesLayer=IV_INTERIOR_PROFILES" 'sOut = sOut & "&FeatureProfilesLayer=IV_Profiles" sOut = sOut & "&TangentLayer=IV_Tangent" 'sOut = sOut & "&BendLayer=IV_BEND" 'Alternativ zu BendUp/-Down sOut = sOut & "&BendUpLayer=IV_Bend" sOut = sOut & "&BendDownLayer=IV_BendDown" 'sOut = sOut & "&ToolCenterLayer=IV_ToolCenter" sOut = sOut & "&ArcCentersLayer=IV_ArcCenter" 'sOut = sOut & "&SimplifySplines=True" 'sOut = sOut & "&SplineTolerance=0.01" 'sOut = sOut & "&TangentLayerColor=255;0;0" 'Beispiel Farbeinstellung (RGB) sOut = sOut & "&InvisibleLayers=IV_ArcCenter;IV_TANGENT;IV_BEND;IV_BendDown;IV_ArcCenter;IV_Featrue_Profiles;IV_Feature_Profiles_Down" 'hier aufgelistete Layer (getrennt durch ";"), werden oDataIO.WriteDataToFile sOut, dxfFileName 'doc.Close (True) Debug.Print sOut End Function Function BlechteilParameter() Dim oPart As PartDocument Dim oFace As Face Dim oThicknessParam As Parameter Dim oSheetMetalCompDef As SheetMetalComponentDefinition Dim Stueckzahl As Integer Dim Kantungen As String Dim tKantungen As Bend Dim dArea As Double Dim dVolume As Double Dim dThickness As Double Dim dContour As Double Stueckzahl = 0 ' Aktives Dokument holen Set oPart = ThisApplication.ActiveDocument dArea = 0 For Each oFace In oPart.ComponentDefinition.SurfaceBodies(1).Faces ' Gesamtfläche berechnen dArea = dArea + oFace.Evaluator.area Next 'Volumen berechnen dVolume = Round(oPart.ComponentDefinition.SurfaceBodies(1).Volume(0.01) * 10, 2)
Set oSheetMetalCompDef = oPart.ComponentDefinition Set oThicknessParam = oSheetMetalCompDef.Thickness ' Blechstärke berechnen dThickness = Round(oThicknessParam.ModelValue * 10, 2) ' Kontur berechnen dContour = Round(((dArea - (2 * (dVolume / dThickness))) / dThickness) * 10, 2) Dim oFP As FlatPattern Set oFP = oSheetMetalCompDef.FlatPattern Dim dLaenge, dBreite, dimZ As Double Dim sdimXYZ As String On Error Resume Next dLaenge = Round((oFP.Body.RangeBox.MaxPoint.X - oFP.Body.RangeBox.MinPoint.X) * 10, 2) dBreite = Round((oFP.Body.RangeBox.MaxPoint.Y - oFP.Body.RangeBox.MinPoint.Y) * 10, 2) 'MsgBox ("Fläche:" & vbTab & vbTab & Round(dArea, 2) & " cm^2" & vbCrLf & _ "Volumen:" & vbTab & vbTab & Round(dVolume, 2) & " cm^3" & vbCrLf & _ "Blechstärke:" & vbTab & Round(dThickness, 2) & " cm" & vbCrLf & vbCrLf & _ "Konturlänge:" & vbTab & Round(dContour, 2) & " cm") Dim oBOMRow As BOMRow Dim tmp As Object For Each tmp In oBom.BOMViews If tmp.ViewType = kPartsOnlyBOMViewType Then For Each oBOMRow In tmp.BOMRows Dim a As Document Set a = oBOMRow.ComponentDefinitions.Item(1).Document If a.DisplayName = oPart.DisplayName Then Stueckzahl = oBOMRow.ItemQuantity 'MsgBox a.DisplayName & " : " & oBOMRow.ItemQuantity End If Next 'MsgBox "Ich habe " & tmp.BOMRows.Count & " Bauteile gezählt" End If Next Kantungen = " " For Each tKantungen In oSheetMetalCompDef.Bends If Not tKantungen.IsFlat Then Kantungen = "Kantung prüfen" Exit For End If Next Call WriteFile(oPart, oPart.DisplayName & ";" & dContour & ";" & dThickness & ";" & Round(dVolume, 2) & ";" & dLaenge & ";" & dBreite & ";" & Kantungen & ";" & Stueckzahl) End Function Function ConvertToSheetMetal(doc As PartDocument) 'MsgBox (doc.SubType) ' Turn it into a sheet metal part doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Dim cd As SheetMetalComponentDefinition Set cd = doc.ComponentDefinition cd.UseSheetMetalStyleThickness = False cd.Thickness.Value = GetThickness(cd.SurfaceBodies(1)) On Error GoTo weiter Call cd.Unfold Call BlechteilParameter Call dxferzeugen(doc) Dim oFP As FlatPattern Set oFP = doc.ActivatedObject
oFP.ExitEdit doc.Save doc.Close Exit Function weiter: doc.SubType = "{4D29B490-49B2-11D0-93C3-7E0706000000}" MsgBox (doc.DisplayName + " kann nicht abgewickelt werden") doc.Save doc.Close End Function Function WriteFile(doc As PartDocument, aStr As String) Dim filesystem As Object Dim pfad As String Set filesystem = CreateObject("Scripting.FilesystemObject") pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\info\" If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad Open pfad + "\Teileinfo.txt" For Append As #1 'Open file for output Print #1, aStr 'Write comma-delimited data Close #1 'Close file End Function Function WriteFileHead(doc As Document, aStr As String) Dim filesystem As Object Dim pfad As String Set filesystem = CreateObject("Scripting.FilesystemObject") pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\info\" If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad Open pfad + "\Teileinfo.txt" For Output As #1 'Open file for output Print #1, aStr 'Write comma-delimited data Close #1 'Close file End Function
Function Stueckliste_erstellen() 'oBom global zum durchsuchen in anderen Funktionen Dim oDoc As AssemblyDocument Set oDoc = ThisApplication.ActiveDocument Set oBom = oDoc.ComponentDefinition.BOM oBom.StructuredViewFirstLevelOnly = False oBom.StructuredViewEnabled = False oBom.PartsOnlyViewEnabled = True
End Function Sub Laserteilkalkulation() Dim doc As Document 'Call OpenDoc2 'Call Dateiliste Set doc = ThisApplication.ActiveDocument Dim allDocs As Documents Set allDocs = ThisApplication.Documents ' Iterate through the contents of the Documents collection. Dim singleDoc As Document Dim Anzahl As Integer Anzahl = 0 Call Stueckliste_erstellen Call WriteFileHead(doc, "Name;Konturlänge;Blechstärke;Volumen;Länge(X)mm;Breite(Y)mm;Kantungen;Stückzahl") For Each singleDoc In allDocs If (singleDoc.DocumentType = kPartDocumentObject) Then Call ConvertToSheetMetal(singleDoc) Anzahl = Anzahl + 1 End If Next MsgBox ("Fertig! " & Anzahl & " Teile wurden bearbeitet.") End Sub Sub OpenDoc(datei As String) Dim oDoc As Document Set oDoc = ThisApplication.Documents.Open(datei) oDoc.Activate End Sub
Sub OpenDoc2() Dim oDoc As Document Dim oFileDlg As Inventor.FileDialog Call ThisApplication.CreateFileDialog(oFileDlg) oFileDlg.InitialDirectory = "c:\" oFileDlg.FileName = "*" Call oFileDlg.ShowOpen Call OpenDoc(oFileDlg.FileName) End Sub Sub Dateiliste() LKForm1.Show If LKForm1.CBabbruch.Value Then this.Exit End If Dim i As Integer For i = 0 To LKForm1.ListBox1.ListCount - 1 Call OpenDoc(LKForm1.ListBox1.List(i, 0)) Call Laserteilkalkulation Next End Sub Vielen Vielen Dank nochmals für eure Hilfe... <3 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 06. Jul. 2021 07:53 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
|
gunni0815 Mitglied Maschinenbau Techniker
Beiträge: 42 Registriert: 23.04.2014
|
erstellt am: 06. Jul. 2021 08:28 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hi, hatte ich doch oben schon geschrieben.. Aus einer Stepbaugruppe alle Teile zum Blech.ipt konvertieren, abwickeln und als .dxf speichern. Dazugekommen ist jetzt noch das Erstellen einer Textdatei mit allen Blechinformationen (Stärke, länge, breite, Volumen, Anzahl in BG, etc. ..) um eine Preiskalkulation via Excel auszuführen.. Gruß Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
EIBe 3D Mitglied Dipl. - Ing. (FH)
Beiträge: 267 Registriert: 24.01.2020 HP Z4 G4 Workstation Xeon 3,6 32GB Nvidia P2000 WIN10 SW2015 SP5.0 SW2017 ************* Inv2018 akt.SP
|
erstellt am: 06. Jul. 2021 09:38 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Immer noch ins Blaue geraten mutmaße ich nun dass du nicht weißt wie die txtDatei zu erstellen ist.
Code:
Private Sub SchreibeTxtDatei() Dim fs As Object, txtFile As Object Set fs = CreateObject("Scripting.FileSystemObject") Dim Path As String, txtFileName As String, txtFileFullName As String Path = "C:\Temp\" 'Anpassen Ordner muss vorhanden sein txtFileName = "MeineTextDatei.txt" 'Name und ggf. Endung anpassen txtFileFullName = Path & txtFileName If fs.FileExists(txtFileFullName) Then fs.Delete Set txtFile = fs.CreateTextFile(txtFileFullName, True) txtFile.WriteLine ("ErsteEigenschaft") txtFile.WriteLine ("ZweiteEigenschaft") txtFile.WriteLine ("usw.") txtFile.Close End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Frank_Schalla Ehrenmitglied CAD_SYSTEMBETREUER
Beiträge: 1732 Registriert: 06.04.2002 DELL M6800 Cad Admin Methodikentwickler 3D
|
erstellt am: 09. Jul. 2021 09:15 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hi Krabby An den Splines habe ich mir auch die Zähne ausgebissen. So gehts Alt 'sOut = sOut & "&SimplifySplines=True" 'auskom.; ansonsten Fehler beim Export !?! 25.06.2018 'sOut = sOut & "&SplineTolerance=0.01" 'auskom.; -"- Neu sOut = sOut & "&SimplifySplines=True" 'SplineTolerance Double 0.01 sOut = sOut & "&SplineTolerance=0,1" ------------------ ************************************ Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
KraBBy Mitglied Maschinenbau-Ingenieur
Beiträge: 720 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 10. Jul. 2021 13:36 <-- editieren / zitieren --> Unities abgeben: Nur für minimal
Hi Frank, herzlichen Dank fürs genaue lesen und den Tipp! Werde ich ausprobieren und wohl auch verwenden. (verstehen muss man das nicht, oder? Vmtl von der Windows Einstellung zum Trennzeichen abhängig...?) ------------------ Gruß KraBBy Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|