Attribute VB_Name = "SheetMetal2DXF"
' The sample code below writes a sheet metal file out as DXF.
' DWG is also supported.
' There are several optional arguments that can be specified
' as part of the format string. Below are the names of
' these arguments and their default values. The output will use
' these values unless you override them as part of the input string.
'
'
' TangentLayer = "IV_TANGENT"
'
' BendLayer = "IV_BEND"
'
' ToolCenterLayer = "IV_TOOL_CENTER"
'
' ArcCentersLayer = "IV_ARC_CENTERS"
'
' OuterProfileLayer = "IV_OUTER_PROFILE"
'
' FeatureProfilesLayer = "IV_FEATURE_PROFILES"
'
' InteriorProfilesLayer = "IV_INTERIOR_PROFILES"
'
' AcadVersion = "2000" (Can be "R12", "R13", "R14", or "2000")
'
'



Public Sub WriteSheetMetalDXF()
'
' The following sample demonstrates creating an R12 DXF file
' that will have a layer called "Outer" where the curves
' for the outer shape will be created.
'
'---------------------------------------------------------------------------------
'(c) Lothar Boekels Ingenieurbüro für Maschinenbau 2004
'    Schroerskamp 74
'    41069 Mönchengladbach
'    kontakt@boekels-online.de
'
'---------------------------------------------------------------------------------

' 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
    
    'MsgBox (sFullName & vbCrLf & vbCrLf & sPath & vbCrLf & sName & vbCrLf & sDXFName)
    
    'Exit Sub
    
    Dim sMsg As String
    
    'MsgBox (Dir(sPath + sDXFName, vbNormal))
    
    
       
    
    If Not Dir(sPath + sDXFName, vbNormal) = "" Then
        'Abfrage nur dann, wenn Datei existiert
        
        sTitel = "Achtung - überschreiben ?"
    
        sMsg = vbCrLf & "Soll Datei " & vbCrLf _
             & vbCrLf & sPath _
             & vbCrLf & sDXFName & vbCrLf _
             & vbCrLf & "überschrieben werden ?" _
             & vbCrLf
    
        If MsgBox(sMsg, vbOKCancel, sTitel) = vbCancel Then
            MsgBox ("Bestehende Datei " & Dir(sPath + sDXFName, vbNormal) & " beibehalten.")
            Exit Sub
        End If
        
    Else
    
        'Abfrage, wenn Datei neu erstellt wird
        
        sTitel = "Neue Datei erstellen ?"
    
        sMsg = vbCrLf & "Soll Datei " & vbCrLf _
             & vbCrLf & sPath _
             & vbCrLf & sDXFName & vbCrLf _
             & vbCrLf & "erstellt werden ?" _
             & vbCrLf
    
        If Not MsgBox(sMsg, vbYesNoCancel, sTitel) = vbYes Then
            'MsgBox ("Abwicklung " & Dir(sPath + sDXFName, vbNormal) & " NICHT erstellt.")
            Exit Sub
        End If
    
    
    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" _
        + "&FeatureProfilesLayer=IV_FEATURE_PROFILES" _
        + "&TangentLayer=IV_TANGENT" _
        + "&BendLayer=IV_BEND" _
        + "&ToolCenterLayer=IV_TOOL_CENTER" _
        + "&ArcCentersLayer=IV_ARC_CENTERS" _
        + ""
 
 
    ' Create the DXF file.
    On Error GoTo Fehler
    oDataIO.WriteDataToFile sOut, sPath + sDXFName
    GoTo endeSub
    
Fehler:
    Call MsgBox("Beim Speichern ist ein Fehler aufgetreten!", vbCritical)

    
endeSub:

Set oDoc = Nothing
    
End Sub