Hello
Yes here it is
Sub Export_Plasma()
'define the active document as an assembly file
Dim oAsmDoc As AssemblyDocument
Set oAsmDoc = ThisApplication.ActiveDocument
Dim oAsmName As String
oAsmName = Left(oAsmDoc.DisplayName, Len(oAsmDoc.DisplayName) - 4)
'check that the active document is an assembly file
If ThisApplication.ActiveDocument.DocumentType <> kAssemblyDocumentObject Then
MsgBox ("Please run this rule from the assembly file.")
Exit Sub
End If
'get user input
result = MsgBox("This will create plasma DWG file for all of the asembly components that are sheet metal." _
& vbLf & "This rule expects that the part file is saved." _
& vbLf & " " _
& vbLf & "Are you sure you want to create plasma DWG for all of the assembly components?" _
& vbLf & "This could take a minute.", vbYesNo, "This create DWG plasma files ")
If result = vbNo Then
Exit Sub
End If
Dim oPath As String
Dim iSplit As Integer
iSplit = InStrRev(oAsmDoc.FullDocumentName, "\")
oPath = Left(oAsmDoc.FullDocumentName, iSplit - 1)
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
'get DWG target folder path
Dim oFolder As String
oFolder = oPath & "\" & oAsmName & " Plasma Filer"
'Check for the DWG folder and create it if it does not exist
If Len(Dir(oFolder, vbDirectory)) = 0 Then
MkDir oFolder
End If
'- - - - - - - - - - - - -
'- - - - - - - - - - - - -Component - - - - - - - - - - - -
'look at the files referenced by the assembly
Dim oRefDocs As DocumentsEnumerator
Set oRefDocs = oAsmDoc.AllReferencedDocuments
Dim oRefDoc As Document
Dim iptPathName As String
'work the the drawing files for the referenced models
'this expects that the model has been saved
For Each oRefDoc In oRefDocs
If oRefDoc.DocumentSubType.DocumentSubTypeID = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
Dim oDrawDoc As PartDocument
Set oDrawDoc = ThisApplication.Documents.Open(oRefDoc.FullDocumentName, True)
Dim oDef As SheetMetalComponentDefinition
Set oDef = oDrawDoc.ComponentDefinition
Dim oThick As String
oThick = oDef.ActiveSheetMetalStyle.Thickness
Dim oMaterial As String
oMaterial = oDrawDoc.ActiveMaterial.DisplayName
oFolder = oPath & "\" & oAsmName & " Plasma Filer\" & oThick & "-" & oMaterial
'Check for the DWG folder and create it if it does not exist
If Len(Dir(oFolder, vbDirectory)) = 0 Then
MkDir oFolder
End If
oFilename = Left(oRefDoc.DisplayName, Len(oRefDoc.DisplayName) - 4)
'Set the DWG target file name
oDataMedium.FileName = oFolder & "\" & oFilename & ".dwg"
Dim oCompDef As SheetMetalComponentDefinition
Set oCompDef = oDrawDoc.ComponentDefinition
If oCompDef.HasFlatPattern = False Then
oCompDef.Unfold
Else
oCompDef.FlatPattern.Edit
End If
Dim sOut As String
'config
'Change values located here to change output.
sOut = "FLAT PATTERN DWG?AcadVersion=2004" _
+ "&OuterProfileLayer=Cut&OuterProfileLayerColor= 0;255;0" _
+ "&InteriorProfilesLayer=Cut&InteriorProfilesLayerColor= 0;255;0" _
+ "&FeatureProfilesLayer=Scribe&FeatureProfilesLayerColor= 255;0;255" _
+ "&FeatureProfilesDownLayer=Scribe&FeatureProfilesDownLayerColor= 255;0;255" _
+ "&InvisibleLayers=IV_BEND;IV_BEND_DOWN;IV_TANGENT;IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS;IV_ALTREP_FRONT;IV_ALTREP_BACK;IV_UNCONSUMED_SKETCHES;IV_ROLL_TANGENT;IV_ROLL" _
'/config
Dim Message, Title, Default, MyValue
Message = "Enter a value between 1 and 1000" ' Set prompt.
Title = "Add quantity" ' Set title.
Default = "1" ' Set default.
' Display message, title, and default value.
MyValue = InputBox(Message, Title, Default)
Call oCompDef.DataIO.WriteDataToFile(sOut, oFolder & "\" & oAsmName & "-" & Mid(oFilename, 13) & "-" & MyValue & "pcs" & ".dwg")
'just for check its works coretcly
'i=MessageBox.Show(oDataMedium.FileName, "Title",MessageBoxButtons.OKCancel)
'MessageBox.Show(i,"title",MessageBoxButtons.OK)
'If i=2 Then
'Exit Sub
'End If
oCompDef.FlatPattern.ExitEdit
oDrawDoc.Close
End If
Next
End Sub
