Hi all
I've made a small macro that export Inner and Outer contour. I have attached it. Anybody who wants is welcome to test and use it.
VBA CODE
Code:
Option Explicit
Public Sub WriteSheetMetalDXF()
Dim iv As iv
Set iv = New iv
iv.ActiveEditObject
If Not iv.GetCustom("NOTES/DXF") = True Then
MsgBox ("Part was not exportet")
Exit Sub
End If
' Get the active document. This assumes it is a part document.
Dim odoc As Document
Set odoc = ThisApplication.ActiveEditObject
' Get the DataIO object.
Dim oDataIO As DataIO
Set oDataIO = odoc.ComponentDefinition.DataIO
Dim sOut As String
sOut = "FLAT PATTERN DXF?AcadVersion=2000&OuterProfileLayer=0&InteriorProfilesLayer=0" _
+ "&FeatureProfileLayer=1" _
+ "&SimplifySplines=True&MergeProfilesIntoPolyline=True" _
+ "&InvisibleLayers=IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS"
' &SplineTolerance=0,1 // Bruges hvis der ønsken lavere opløsning
Dim now As String
If iv.GetCustom("NOTES/DXF/DATE") = True Then
now = Date
now = "(" + now + ")"
Else
now = ""
End If
Dim thickness As String
thickness = RemoveTrailingZero(iv.GetParam("Thickness"))
Dim dxfname As String
dxfname = iv.iProperty("Part Number") + "_" _
+ iv.iProperty("Material") + "_" + thickness _
+ " mm - " + iv.GetCustom("NOTES/DXF/QTY") + "Stk." _
+ now + ".dxf"
iv.ActiveDocument
If Len(Dir(iv.FilePath + "DXF\", vbDirectory)) = 0 Then
MkDir iv.FilePath + "DXF"
End If
Dim out As String
out = iv.FilePath + "\DXF\" + dxfname
'Create the DXF file.
oDataIO.WriteDataToFile sOut, out
End Sub
Function RemoveTrailingZero(Value As String)
Dim r As Integer
'MsgBox (Len(Value))
For r = 0 To Len(Value) + 2
If Right(Value, 1) = "0" Or Right(Value, 1) = "," Then
Value = Left(Value, (Len(Value) - 1))
End If
r = r + 1
Next
RemoveTrailingZero = Value
End Function
REQUESTED CLASS
Code:
Option Explicit
' Internal functions
Dim invDoc As Document
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
' Set to ActiveEditObject
Public Function ActiveEditObject() As String
Set invDoc = ThisApplication.ActiveEditObject
End Function
' Set to ActiveDocument
Public Function ActiveDocument() As String
Set invDoc = ThisApplication.ActiveDocument
End Function
' Set to File
Public Function OpenFile(FullFileName) As String
'Dim invApprentice As New ApprenticeServerComponent
'Dim invDoc As ApprenticeServerDocument
'Set invDoc = invApprentice.Open(FullFileName)
Set invDoc = ThisApplication.Documents.Open(FullFileName, True)
End Function
Public Function CloseActiveDocument()
ThisApplication.ActiveDocument.Close True
End Function
' Get FileName
Public Function FileName()
FileName = invDoc.DisplayName
End Function
' Get Path
Public Function FilePath()
FilePath = Left(invDoc.FullDocumentName, Len(invDoc.FullDocumentName) - (Len(invDoc.DisplayName)))
End Function
' Get inventor iProperty
Public Function iProperty(Name As String, Optional NewValue As String)
Dim PropSet As String
Dim IDSI As String
IDSI = "Category,Manager,Company"
Dim ISI As String
ISI = "Title,Subject,Author,Keywords,Comments,Last Saved By,Revision Number,Thumbnail"
If "," + IDSI + "," Like "*," + Name + ",*" Then
PropSet = "Inventor Document Summary Information"
ElseIf "," + ISI + "," Like "*," + Name + ",*" Then
PropSet = "Inventor Summary Information"
Else
PropSet = "Design Tracking Properties"
End If
' Get the property set.
Dim invInfo As PropertySet
Set invInfo = invDoc.PropertySets.Item(PropSet)
If NewValue = "" Then
iProperty = invInfo.Item(Name).Value
Else
invInfo.Item(Name).Value = NewValue
End If
End Function
'Gets parameter from part
Public Function GetParam(paramName As String, Optional UnitType As String) As String
Dim params As ModelParameters
Dim partDoc As PartDocument
Dim assyDoc As AssemblyDocument
Dim newExpression As String
Dim uom As UnitsOfMeasure
If UnitType = "" Then
UnitType = "mm" 'kDefaultDisplayLengthUnits
End If
' cast to the appropriate document type, and get params
' Note: uom can actually be accessed directly from the ThisApplication object
If TypeOf invDoc Is AssemblyDocument Then
Set assyDoc = invDoc
Set params = assyDoc.ComponentDefinition.parameters.ModelParameters
Set uom = assyDoc.UnitsOfMeasure
ElseIf TypeOf invDoc Is PartDocument Then
Set partDoc = invDoc
'Check for document subtype
If partDoc.DocumentSubType.DocumentSubTypeID = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
'Get component's definition
Dim oCompDef As SheetMetalComponentDefinition
Set oCompDef = partDoc.ComponentDefinition
Set params = oCompDef.parameters.ModelParameters
Set uom = partDoc.UnitsOfMeasure
Else
Set params = partDoc.ComponentDefinition.parameters.ModelParameters
Set uom = partDoc.UnitsOfMeasure
End If
End If
If Not (params Is Nothing) Then
' try to get the parameter passed to the function
On Error Resume Next
Dim Param As ModelParameter
Set Param = params.Item(paramName)
If Err.Number <> 0 Then
newExpression = ""
Else
If Not (Param Is Nothing) Then
' convert to an expression in current document units
' this assumes the parameter is a length parameter (no check is made)
newExpression = uom.GetStringFromValue(Param.Value, UnitType)
newExpression = Left(newExpression, (Len(newExpression) - Len(UnitType) - 1))
End If
End If
' assign value for return
GetParam = newExpression
End If
End Function
' Manage Custom properties
Public Function SetCustom(MyPropName As String, Optional MyValue As String, Optional confirm As Boolean) As String
' Get the custom property set.
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = _
invDoc.PropertySets.Item("Inventor User Defined Properties")
' Attempt to get an existing custom property named "Volume".
On Error Resume Next
Dim invVolumeProperty As Property
Set invVolumeProperty = invCustomPropertySet.Item(MyPropName)
If Err.Number <> 0 Then
' Failed to get the property, which means it doesn't exist
' so we'll create it.
Call invCustomPropertySet.Add(MyValue, MyPropName)
Else
' We got the property so update the value.
If confirm = True Then
Dim lReply As Long
lReply = MsgBox("Do you realy want to update value?", vbOKCancel)
If lReply = vbCancel Then Exit Function
'confirm ("Do you realy want to update value?")
End If
invVolumeProperty.Value = MyValue
End If
End Function
Public Function SetCustomInt(MyPropName As String, Optional MyValue As Double, Optional confirm As Boolean) As String
' Get the custom property set.
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = _
invDoc.PropertySets.Item("Inventor User Defined Properties")
' Attempt to get an existing custom property named "Volume".
On Error Resume Next
Dim invVolumeProperty As Property
Set invVolumeProperty = invCustomPropertySet.Item(MyPropName)
If Err.Number <> 0 Then
' Failed to get the property, which means it doesn't exist
' so we'll create it.
Call invCustomPropertySet.Add(MyValue, MyPropName)
Else
' We got the property so update the value.
If confirm = True Then
Dim lReply As Long
lReply = MsgBox("Do you realy want to update value?", vbOKCancel)
If lReply = vbCancel Then Exit Function
'confirm ("Do you realy want to update value?")
End If
invVolumeProperty.Value = MyValue
End If
End Function
Public Function SetCustomDate(MyPropName As String, Optional MyValue As Date, Optional confirm As Boolean) As String
' Get the custom property set.
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = _
invDoc.PropertySets.Item("Inventor User Defined Properties")
' Attempt to get an existing custom property named "Volume".
On Error Resume Next
Dim invVolumeProperty As Property
Set invVolumeProperty = invCustomPropertySet.Item(MyPropName)
If Err.Number <> 0 Then
' Failed to get the property, which means it doesn't exist
' so we'll create it.
Call invCustomPropertySet.Add(MyValue, MyPropName)
Else
' We got the property so update the value.
If confirm = True Then
Dim lReply As Long
lReply = MsgBox("Do you realy want to update value?", vbOKCancel)
If lReply = vbCancel Then Exit Function
'confirm ("Do you realy want to update value?")
End If
invVolumeProperty.Value = MyValue
End If
End Function
Public Function SetCustomBool(MyPropName As String, Optional MyValue As Boolean, Optional confirm As Boolean) As String
' Get the custom property set.
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = _
invDoc.PropertySets.Item("Inventor User Defined Properties")
' Attempt to get an existing custom property named "Volume".
On Error Resume Next
Dim invVolumeProperty As Property
Set invVolumeProperty = invCustomPropertySet.Item(MyPropName)
If Err.Number <> 0 Then
' Failed to get the property, which means it doesn't exist
' so we'll create it.
Call invCustomPropertySet.Add(MyValue, MyPropName)
Else
' We got the property so update the value.
If confirm = True Then
Dim lReply As Long
lReply = MsgBox("Do you realy want to update value?", vbOKCancel)
If lReply = vbCancel Then Exit Function
'confirm ("Do you realy want to update value?")
End If
invVolumeProperty.Value = MyValue
End If
End Function
Public Function GetCustom(MyPropName As String, Optional confirm As Boolean) As String
' Get the custom property set.
Dim invCustomPropertySet As PropertySet
Set invCustomPropertySet = _
invDoc.PropertySets.Item("Inventor User Defined Properties")
' Attempt to get an existing custom property named "Volume".
On Error Resume Next
Dim invVolumeProperty As Property
Set invVolumeProperty = invCustomPropertySet.Item(MyPropName)
If Err.Number <> 0 Then
' Failed to get the property, which means it doesn't exist
' so we'll create it.
If confirm = True Then
MsgBox ("Property does not exists")
Else
GetCustom = False
End If
Else
' We got the property so update the value.
GetCustom = invVolumeProperty.Value
End If
End Function
Before running macro you have to fill in some custom properties, please see attached picture.
Hoping this is any use!
Login
Register
FAQ
Search
