Inventor Customization

Inventor Customization

Reply
Valued Mentor
BLHDrafting
Posts: 350
Registered: ‎10-12-2012
Message 1 of 3 (502 Views)
Accepted Solution

FREE SAVE DXF MACRO FOR YOUR HELP!

502 Views, 2 Replies
02-06-2013 02:23 PM

 

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. :smileysad:

 

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



 

Brendan Henderson

Web www.blh.com.au
Twitter @BLHDrafting

Windows 7 x64 -64 GB Ram, Intel Xeon E5-1620 @ 3.6 GHz
ATI FirePro V7800 2 GB, 180 GB SSD & 1 TB HDD, Inv R2013 PDS Premium SP2 Update 3 (Build 200), Vault 2013 Workgroup Update 2 (Build 17.2.9.0)

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

Mentor
matt_jlt
Posts: 220
Registered: ‎07-28-2007
Message 2 of 3 (499 Views)

Re: FREE SAVE DXF MACRO FOR YOUR HELP!

02-06-2013 03:11 PM in reply to: BLHDrafting

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

Valued Mentor
BLHDrafting
Posts: 350
Registered: ‎10-12-2012
Message 3 of 3 (492 Views)

Re: FREE SAVE DXF MACRO FOR YOUR HELP!

02-06-2013 03:30 PM in reply to: matt_jlt

Heaps of thanks to you Matt. It works great. :smileyhappy:

Brendan Henderson

Web www.blh.com.au
Twitter @BLHDrafting

Windows 7 x64 -64 GB Ram, Intel Xeon E5-1620 @ 3.6 GHz
ATI FirePro V7800 2 GB, 180 GB SSD & 1 TB HDD, Inv R2013 PDS Premium SP2 Update 3 (Build 200), Vault 2013 Workgroup Update 2 (Build 17.2.9.0)
Post to the Community

Have questions about Autodesk products? Ask the community.

New Post
Announcements
Do you have 60 seconds to spare? The Autodesk Community Team is revamping our site ranking system and we want your feedback! Please click here to launch the 5 question survey. As always your input is greatly appreciated.