FREE SAVE DXF MACRO FOR YOUR HELP!

[BLHDrafting]

In giving away this very handy macro I'm asking for some help to improve it. I'm not a programmer and I think the person who wrote this has passed on. 😞

Firstly what does the macro do? It creates a DXF file of the current sheetmetal document flat pattern. Basically the same as Save Copy As in the part Flat Pattern environment. Also it creates a few custom iProperties for the part cutting length (InnerPerimeters, OuterPerimeter and TotalPerimeters). These are handy for laser/plasma cutters to base pricing on.

What do I want? I need some help making the saved (output) DXF file name the same as the iProperty Project (on the Project tab of iProperties). Currently I have the iProperty Project = <Part Number>-<Revision Number>.dxf and I need this to be the saved DXF file name. That's all! Seems simple but I can't figure it out.

Any takers?

Sub FP2DXF()

Dim oPartDoc As Document
Set oPartDoc = ThisApplication.ActiveDocument

' The Active document must be a part
If oPartDoc.DocumentType <> kPartDocumentObject Then
    MsgBox "The Active document must be a 'Part'"
    Exit Sub
End If

' The Active document must be a Sheet metal Part
If oPartDoc.SubType <> "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
    MsgBox "The Active document must be a 'Sheet Metal Part'"
    Exit Sub
End If

' Check if part needs to be saved
If oPartDoc.Dirty = True Then
    MsgBox "Please save this Sheet metal part"
    Exit Sub
End If

Dim oFlatPattern As FlatPattern
Set oFlatPattern = oPartDoc.ComponentDefinition.FlatPattern

' There must be a flat pattern
If oFlatPattern Is Nothing Then
    MsgBox "Please create the flat pattern"
    Exit Sub
End If

Dim oDXFfileNAME As String
oDXFfileNAME = Left(oPartDoc.FullFileName, Len(oPartDoc.FullFileName) - 4) & ".DXF"

Dim oDataIO As DataIO
Set oDataIO = oPartDoc.ComponentDefinition.DataIO

Dim sOut As String

    sOut = "FLAT PATTERN DXF?AcadVersion=2000" _
        + "&OuterProfileLayer=OUTER_PROF&OuterProfileLayerColor=255;0;0" _
        + "&InteriorProfilesLayer=INNER_PROFS&InteriorProfilesLayerColor=0;255;255" _
        + "&FeatureProfileLayer=FEATURE&FeatureProfileLayerColor=0;0;255" _
        + "&InvisibleLayers=IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS"
        '+ "&BendUpLayer=BEND_UP&BendUpLayerColor=255;0;255&BendUpLayerLineType=37634" _
        '+ "&BendDownLayer=BEND_DOWN&BendDownLayerColor=255;255;0&BendDownLayerLineType=37634" _
        '+ "&SimplifySplines=True&MergeProfilesIntoPolyline=True" _
        '+ "&InvisibleLayers=IV_TANGENT;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS"
        
   oDataIO.WriteDataToFile sOut, oDXFfileNAME
 
    ' Check for a non-part document
    If oPartDoc.DocumentType <> kPartDocumentObject Then
        MsgBox "The Active document must be a 'Part'"
        Exit Sub
    End If

    ' The Active document must be a Sheet metal Part
    If oPartDoc.SubType <> "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
        MsgBox "The 'Part' must be a Sheet Metal Part"
        Exit Sub
    End If

    Dim oSheetMetalCompDef As SheetMetalComponentDefinition
    Set oSheetMetalCompDef = oPartDoc.ComponentDefinition

    ' Get the cut length
    Dim oFace As Face
    Set oFace = oSheetMetalCompDef.FlatPattern.TopFace

    ' Find the outer loop.
    Dim dOuterLength As Double
    dOuterLength = 0
    Dim oLoop As EdgeLoop
    For Each oLoop In oFace.EdgeLoops
        If oLoop.IsOuterEdgeLoop Then
            Dim oEdge As Edge
            For Each oEdge In oLoop.Edges
                ' Get the length of the current edge.
                Dim dMin As Double, dMax As Double
                Call oEdge.Evaluator.GetParamExtents(dMin, dMax)
                Dim dLength As Double
                Call oEdge.Evaluator.GetLengthAtParam(dMin, dMax, dLength)
                dOuterLength = dOuterLength + dLength
            Next
            'MsgBox "Outer Loop is " & FormatNumber(dOuterLength, 1)
            Exit For
        End If
    Next

    ' Iterate through the inner loops.
    Dim iLoopCount As Long
    iLoopCount = 0
    Dim dTotalLength As Double
    For Each oLoop In oFace.EdgeLoops
        Dim dLoopLength As Double
        dLoopLength = 0
        If Not oLoop.IsOuterEdgeLoop Then
            For Each oEdge In oLoop.Edges
                ' Get the length of the current edge.
                Call oEdge.Evaluator.GetParamExtents(dMin, dMax)
                Call oEdge.Evaluator.GetLengthAtParam(dMin, dMax, dLength)
                dLoopLength = dLoopLength + dLength
            Next

            ' Add this loop to the total length.
            dTotalLength = dTotalLength + dLoopLength
            'MsgBox "Inner Loops are " & FormatNumber(dTotalLength, 1)
        End If
    Next

    Dim oUom As UnitsOfMeasure
    Set oUom = oPartDoc.UnitsOfMeasure
        
    outerCutlength = oUom.GetStringFromValue(dOuterLength, kMillimeterLengthUnits)
    innerCutlength = oUom.GetStringFromValue(dTotalLength, kMillimeterLengthUnits)
    TotalCutLength = oUom.GetStringFromValue(dTotalLength + dOuterLength, kMillimeterLengthUnits)

    'Write data to properties, creating or updating (if property exists)
    Dim oCustomPropSet As PropertySet
    Set oCustomPropSet = oPartDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")

    On Error Resume Next
    oCustomPropSet.Item("OuterPerimeter").Value = outerCutlength
    If Err Then
        Err.Clear
        Call oCustomPropSet.Add(outerCutlength, "OuterPerimeter")
    End If
    oCustomPropSet.Item("InnerPerimeters").Value = innerCutlength
    If Err Then
        Err.Clear
        Call oCustomPropSet.Add(innerCutlength, "InnerPerimeters")
    End If
    oCustomPropSet.Item("TotalPerimeter").Value = TotalCutLength
    If Err Then
        Err.Clear
        Call oCustomPropSet.Add(TotalCutLength, "TotalPerimeter")
    End If
End Sub

[matt_jlt · Accepted solution]

Hi Brendan, this should hopefully do the trick.

Replace the following:

Dim oDXFfileNAME As String
oDXFfileNAME = Left(oPartDoc.FullFileName, Len(oPartDoc.FullFileName) - 4) & ".DXF"

with new code below

Dim strProject As String
strProject = oPartDoc.PropertySets("Design Tracking Properties").Item("Project").Value

Dim strPath As String
strPath = Left(oPartDoc.FullFileName, InStrRev(oPartDoc.FullFileName, "\"))

Dim oDXFfileNAME As String
oDXFfileNAME = strPath & strProject & ".dxf"

Regards, Matt.

If this is correct please mark it as the answer

[BLHDrafting]

Heaps of thanks to you Matt. It works great.