Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Blech Abwicklung DXF

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
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Blech Abwicklung DXF (1255 mal gelesen)
oklaf75
Mitglied



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

Beiträge: 11
Registriert: 01.08.2013

erstellt am: 24. Jul. 2017 14:54    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

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


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

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 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 oklaf75 10 Unities + Antwort hilfreich

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


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

Beiträge: 51
Registriert: 14.09.2014

Win10 IV2018 Vault2018-WG

erstellt am: 25. Jul. 2017 01:23    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 oklaf75 10 Unities + Antwort hilfreich

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


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

Beiträge: 51
Registriert: 14.09.2014

Win10 IV2018 Vault2018-WG

erstellt am: 25. Jul. 2017 01:40    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 oklaf75 10 Unities + Antwort hilfreich

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



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

Beiträge: 11
Registriert: 01.08.2013

erstellt am: 25. Jul. 2017 08:41    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

Hallo.

Funktioniert wunderbar.

Vielen Dank für die Hilfe.

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)2023 CAD.de | Impressum | Datenschutz