| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte | | | | PNY präsentiert die neue NVIDIA RTX A400 und die A1000 Grafikkarte, eine Pressemitteilung
|
Autor
|
Thema: Blech Abwicklung DXF (1330 / mal gelesen)
|
oklaf75 Mitglied
Beiträge: 11 Registriert: 01.08.2013
|
erstellt am: 24. Jul. 2017 14:54 <-- editieren / zitieren --> Unities abgeben:
Hallo. Ich habe hier ein Makro was soweit funktioniert. Aus einem Blechteil wird eine Abwicklung erstellt und daraus eine dxf erzeugt mit der Bezeichnung aus der ipt. Code: Attribute VB_Name = "M14"Public Sub Blech_in_DXF() ' Nur im Sheet Metal Part: If Not ((ThisApplication.ActiveDocumentType = kPartDocumentObject) _ And (ThisApplication.ActiveDocument.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}")) Then MsgBox "Must be a SheetMetalPart" GoTo endeSub End If ' Get the active document. This assumes it is a part document. Dim odoc As PartDocument Set odoc = ThisApplication.ActiveDocument ' Blechteil abwickeln Dim oFlatPattern As FlatPattern Set oFlatPattern = odoc.ComponentDefinition.FlatPattern If oFlatPattern Is Nothing Then odoc.ComponentDefinition.Unfold Else odoc.Update End If ' Abwicklung speichern Dim sFullName As String Dim sName As String Dim sDXFName As String Dim sPath As String Dim sPath_Vault As String Dim sLokalerAB_Kenner As String ' Ermitteln des Standortes und des Names der IPT. ' Die Abwicklung (DXF-Datei) wird in den gleichen Pfad geschrieben, wo die IPT steht. ' Sie hat den gleichen Namen wie die IPT - nur die Extension ist .DXF . sFullName = odoc.FullFileName sName = sFullName Do While InStr(1, sName, "\", vbTextCompare) > 0 sName = Right$(sName, Len(sName) - InStr(1, sName, "\", vbTextCompare)) Loop sDXFName = Left$(sName, Len(sName) - 4) + ".dxf"
sPath = Left$(sFullName, Len(sFullName) - Len(sName)) 'Großbuchstaben für den DriveLetter If InStr(1, sPath, ":\", vbTextCompare) > 0 Then sPath = UCase(Left$(sPath, 1)) & Right$(sPath, Len(sPath) - 1) 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. ' The output will use these values unless you override them as part of the input string. ' Weglassen hilft nicht! ' Argument Type Note ' TangentLayer String ' OuterProfileLayer String ' ArcCentersLayer String ' InteriorProfilesLayer String ' BendLayer String BendUpLayer + BendDownLayer (legacy support) ' BendUpLayer String ' BendDownLayer String ' ToolCenterLayer String ToolCenterUpLayer + ToolCenterDownLayer (legacy support) ' ToolCenterUpLayer String ' ToolCenterDownLayer String ' FeatureProfilesLayer String FeatureProfilesUpLayer + FeatureProfilesDownLayer (legacy support) ' FeatureProfilesUpLayer String ' FeatureProfilesDownLayer String ' AcadVersion String 2007, 2004, 2000, or R12 (for DXF only) ' CustomizeFilename String ' SimplifySplines Boolean ' SplineTolerance Double ' AdvancedLegacyExport Boolean ' MergeOuterContour Boolean ' RebaseGeometry Boolean ' InvisibleLayers String List of layer names to make invisible, seperated by ; Dim sOut As String ' sOut = "FLAT PATTERN DXF?" _ ' + "TangentLayer=Tangents" _ ' + "&SimplifySplines=True" sOut = "FLAT PATTERN DXF?" _ + "AcadVersion=R12" _ + "&OuterProfileLayer=IV_OUTER_PROFILE" _ + "&InteriorProfilesLayer=IV_INTERIOR_PROFILES" _ + "&InvisibleLayers=IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES_DOWN;IV_ALTREP_FRONT;IV_ALTREP_BACK;IV_UNCONSUMED_SKETCHES;IV_ROLL_TANGENT;IV_ROLL" _ + ""
' Create the DXF file. On Error GoTo Fehler oDataIO.WriteDataToFile sOut, sPath & "Brennteile\" & sDXFName GoTo endeSub Fehler: Call MsgBox("Beim Speichern ist ein Fehler aufgetreten!", vbCritical)
endeSub: Set odoc = Nothing End Sub
Nun möchte ich aber das die Bezeichnung aus den iProperties verwendet wird. "Design Tracking Properties" - "Part Number" Wie muss das Makro angepasst werden? Danke! Oklaf
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Chris 31 Mitglied Konstrukteur und Mädchen für alles
Beiträge: 575 Registriert: 23.04.2013 Inventor 2013/2015 Windows 7 64 bit 16GB RAM nVidia Quadro 600
|
erstellt am: 24. Jul. 2017 16:00 <-- editieren / zitieren --> Unities abgeben: Nur für oklaf75
Code:
... ' Ermitteln des Standortes und des Names der IPT. ' Die Abwicklung (DXF-Datei) wird in den gleichen Pfad geschrieben, wo die IPT steht. ' Sie hat den gleichen Namen wie die IPT - nur die Extension ist .DXF . sFullName = odoc.FullFileName sName = sFullName Do While InStr(1, sName, "\", vbTextCompare) > 0 sName = Right$(sName, Len(sName) - InStr(1, sName, "\", vbTextCompare)) Loop sDXFName =odoc.PropertySets.Item("Design Tracking Properties").Item(5).Value + ".dxf" 'sDXFName = Left$(sName, Len(sName) - 4) + ".dxf" sPath = Left$(sFullName, Len(sFullName) - Len(sName)) 'Großbuchstaben für den DriveLetter If InStr(1, sPath, ":\", vbTextCompare) > 0 Then sPath = UCase(Left$(sPath, 1)) & Right$(sPath, Len(sPath) - 1) End If ...
So sollte es gehen. ------------------ MFG Chris Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
bkrüger Mitglied Konstrukteur
Beiträge: 51 Registriert: 14.09.2014 Win10 IV2018 Vault2018-WG
|
erstellt am: 25. Jul. 2017 01:23 <-- editieren / zitieren --> Unities abgeben: Nur für oklaf75
Hallo Oklaf, ich habs mal komplettiert, hoffe dass die Kommentierung ausreichend ist. Falls die const csout= - Zeile zerhackt ist: String zwischen den Anführungszeichen ohne Leerzeichen zusammensetzen. Code:
Public Sub Blech_in_DXF() 'das ist fix: Const csOut = "FLAT PATTERN DXF?AcadVersion=R12&OuterProfileLayer=IV_OUTER_PROFILE&InteriorProfilesLayer=IV_INTERIOR_PROFILES&InvisibleLayers=IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES_DOWN;IV_ALTREP_FRONT;IV_ALTREP_BACK;IV_UNCONSUMED_SKETCHES;IV_ROLL_TANGENT;IV_ROLL"'nur eins von den dreien auf true: Const mitDateiname = False Const mitbauteilnummer = True Const mitbezeichnung = False 'Option: - mit oder ohne Untervz für dxf (Existenz wird nicht geprüft!): '(nicht gewünschtes auskommentieren) 'Const csubsub = "Brennteile\" ' dxf in ipt-Vz/Brennteile Const csubsub = "" 'dxf direkt ins ipt-Vz Dim sERR As String 'für FEhlermeldung Dim opart As PartDocument 'die ipt Dim sFullName As String ' dessen fullname Dim sTemp1 As String 'temporär Dim sDXFName As String ' Fullname der dxf Dim sPath As String ' Pfad der dxf Dim lPunkt As Long 'Position des letzten Punktes im Fullnamen Dim lSlash As Long 'POsition des letzten Slashs im Fullnamen Dim llen As Long 'temp. Länge Dim bvd As Boolean 'Flag - ungültige(s) Zeichen im Dateinamen Dim lix As Long 'index für for next Dim TheUserSay As Long 'msgbox Userwahl Dim oDataIO As DataIO Dim csverbose As String '= "/*:\?<>|" & Chr(34) 'die unerwünschten Zeichen im Dateinamen '------------------------------------ 'Vorspiel: '1.Datei im Inventor offen? '2.Datei eine ipt? '3.Diese ipt ein Blechteil? '4.Dieses Blechteil bereits gespeichert? '5. Abwicklung, wenn noch keine vorhanden '5.1. Erfolgskontrolle Abwicklung ' Hauptteil. '6. Je nach Wunsch (const mit...) dxf-Dateinamen aus ipt-Namen oder BTNr oder Bezeichnung, '6.1. wenn aus iprop, check auf unzulässige Zeichen '7. Falls dxf-datei existiert, diese löschen '8. dxf ausgeben mit Erfolgsmeldung '----------------------------------------------------------------------------- sERR = "Keine Datei geöffnet" If ThisApplication.ActiveDocument Is Nothing Then GoTo Fehler '(1) sERR = "Geöffnete Datei muß eine ipt sein" If ThisApplication.ActiveDocument.DocumentType <> kPartDocumentObject Then GoTo Fehler '(2) sERR = "Datei wurde noch nicht gespeichert, zuerst speichern" If ThisApplication.ActiveDocument.FileSaveCounter = 0 Then GoTo Fehler '(4) Set opart = ThisApplication.ActiveDocument sERR = "Geöffnete ipt ist kein Blechteil" If opart.DocumentSubType.DocumentSubTypeID <> "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then GoTo Fehler '(3) If opart.ComponentDefinition.FlatPattern Is Nothing Then opart.ComponentDefinition.Unfold '(5) opart.Update sERR = "Abwicklung fehlgeschlagen" If opart.ComponentDefinition.FlatPattern Is Nothing Then GoTo Fehler '(5.1.) sERR = "Unerwarteter Fehler: Fullname ist leer" sFullName = opart.FullFileName If sFullName = "" Then GoTo Fehler lPunkt = InStrRev(sFullName, ".") lSlash = InStrRev(sFullName, "\") sERR = "Unerwarteter Fehler in Fullname : " & vbCrLf & sFullName If (lPunkt = 0) Or (lSlash = 0) Then GoTo Fehler sPath = Left(sFullName, lSlash) & csubsub If mitDateiname Then sDXFName = Left(sFullName, lPunkt) & "dxf" '(6) Else If mitbauteilnummer Then sTemp1 = opart.PropertySets("Design Tracking Properties").Item("Part Number").Value sERR = "Iprop Bauteilnummer leer" If sTemp1 = "" Then GoTo Fehler End If If mitbezeichnung Then 'ODER mit iprop Bezeichnung: sTemp1 = opart.PropertySets("Design Tracking Properties").Item("Description").Value sERR = "Iprop Bezeichnung leer" If sTemp1 = "" Then GoTo Fehler End If '----------------------------------------------------------------------------------------- 'jetzt Check auf Dateinamenfähigkeit: csverbose = "/*:\?<>|" & Chr(34) '(6.1.) llen = Len(csverbose) bvd = False For lix = 1 To llen If InStr(sTemp1, Mid(csverbose, lix, 1)) > 0 Then bvd = True Next lix If bvd Then sERR = "Ungültige Zeichen in der Iprop " & vbCrLf & sTemp1 TheUserSay = MsgBox("Ungültige Zeichen in der Iprop, Korrigieren?", vbYesNo, "Frage") If TheUserSay = vbNo Then GoTo Fehler For lix = 1 To llen sTemp1 = Replace(sTemp1, Mid(csverbose, lix, 1), "_") Next lix End If sDXFName = sPath & sTemp1 & ".dxf" End If ' Exist dxfname? If Dir(sDXFName) <> "" Then 'Überschreiben ohne Rückfrage, vorher evtl. RO-Attribut rücksetzen SetAttr sDXFName, vbNormal Kill (sDXFName) '(7) 'hier ggf. Lösch-Erfolg überprüfen sERR = "Bestehende DXF " & vbCrLf & sDXFName & vbCrLf & " lässt sich nicht löschen" If Dir(sDXFName) <> "" Then GoTo Fehler End If ' jetzt gehts los Set oDataIO = opart.ComponentDefinition.DataIO sERR = "DXF Erstellung fehlgeschlagen" On Error GoTo Fehler ' DXF-Ausgabe: oDataIO.WriteDataToFile csOut, sDXFName '(8) 'wenn kein Fehler war: MsgBox "DXF erstellt " & vbCrLf & sDXFName, vbInformation, "Alles gut" Exit Sub Fehler: MsgBox sERR, vbCritical, " Abbruch" End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
bkrüger Mitglied Konstrukteur
Beiträge: 51 Registriert: 14.09.2014 Win10 IV2018 Vault2018-WG
|
erstellt am: 25. Jul. 2017 01:40 <-- editieren / zitieren --> Unities abgeben: Nur für oklaf75
Nachtrag: Bei Abwicklungen immer auf den korrekten Verkürzungsfaktor kf (abh. von Blechstärke, verwendeten Biegewerkzeug, bzw. Biegeradius - ggf. auch vom Biegewinkel) achten. Ich verwende für Biegeradius=Blechstärke bis 4mm 0,35 - bis 8mm 0,44 und darüber 0,512 - das ist in der Regel ausreichend um auf Toleranz mittel für Biegewinkel um die 90° hinzukommen. Und: Aufpassen, dass die Abwicklung auch aufs verwendete Rohmaterial (oft ist da schon bei Großformat 3000x1500mm Schluß) passt. [Diese Nachricht wurde von bkrüger am 25. Jul. 2017 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
oklaf75 Mitglied
Beiträge: 11 Registriert: 01.08.2013
|
erstellt am: 25. Jul. 2017 08:41 <-- editieren / zitieren --> Unities abgeben:
|
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|