Sorry for the confusion, I think I understand what you want now. This will add the DXF Files to gauge folders right where the assembly is saved. Hope this helps:
edit: just make sure you don't have any characters in the names of your Sheet Metal Rules that can't be in file or folder names. I did, so this code will do a replace for "/" or inch marks ("). Any others will cause errors and you will have to do a Replace on those as well to get rid of the errors.
Sub Main()
Dim New_Folder_Path As String = ThisDoc.Path
Dim oAsmDoc As AssemblyDocument
oAsmDoc = ThisApplication.ActiveDocument
' Dim Job_confirm As String
' Job_confirm = MsgBox ("Sending Files to DXF Folder " & iProperties.Value("Project", "Project"),vbOKCancel, "Confirm Job #")
' If Job_confirm = "2" Then Exit Sub
My.Computer.FileSystem.CreateDirectory(New_Folder_Path)
'Ask user for REV level
Dim Rev_Level As String = ""
Rev_Level = InputBox ("Enter Rev Level","Creating DXF files For Entire Assembly")
Dim Count_up As Integer = 0
Dim Gauge_Folders(12) As String
Dim Ga As String
Dim doc As document
For Each doc In oAsmDoc.AllReferencedDocuments
If doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
Dim oSheetMetalCompDef As SheetMetalComponentDefinition
oSheetMetalCompDef = doc.ComponentDefinition
Ga = oSheetMetalCompDef.ActiveSheetMetalStyle.Name
Ga = Replace(Ga, "/", "_")
Ga = Replace(Ga, Chr(34), "")
If UBound(Filter(Gauge_Folders, Ga)) > -1 Then
Else
Gauge_Folders(Count_up) = Ga
Gauge_Path = New_Folder_Path & "\" & Ga
My.Computer.FileSystem.CreateDirectory(Gauge_Path)
End If
End If
Next
ReDim Preserve Gauge_Folders(Count_up)
For i = LBound(Gauge_Folders) To UBound(Gauge_Folders)
msg = msg & Gauge_Folders(i) & vbNewLine
Next i
MsgBox ("Adding DXF files to Folders:" & vbNewLine & vbNewLine & msg, ,"Gauges Found")
Count_up = 0
For Each doc In oAsmDoc.AllReferencedDocuments
If doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}" Then
Call Make_DXF(doc, Rev_Level, New_Folder_Path)
End If
Count_up = Count_up + 1
Next
MsgBox("DXF Export Complete",,"All Done")
End Sub
Sub Make_DXF(doc As Document, Rev_L As String, File_Location As String)
Dim oSheetMetalCompDef As SheetMetalComponentDefinition
oSheetMetalCompDef = doc.ComponentDefinition
Dim GA_Adder As String = oSheetMetalCompDef.ActiveSheetMetalStyle.Name
GA_Adder = Replace(GA_Adder, "/", "_")
GA_Adder = Replace(GA_Adder, Chr(34), "")
Dim Part_Name As String = doc.DisplayName
Dim TestPos As Integer = 0
'checking for parts that don't have flat pattern and telling user what parts are skipped for lack of flat pattern
part = doc.ComponentDefinition.Document.FullDocumentName
' Create flat pattern if none
If Not oSheetMetalCompDef.HasFlatPattern() Then
' Open document
openDoc = ThisApplication.Documents.Open(part,False)
' Unfold part
oSheetMetalCompDef.Unfold()
' Exit flat pattern
oSheetMetalCompDef.FlatPattern.ExitEdit()
' Close document
openDoc.Close()
End If
Dim Rev_Adder As String = ""
If Rev_L <> "" Then Rev_Adder = " REV " & Rev_L
TestPos = InStr(1, Part_Name, ".")
If TestPos <> 0 Then
Part_Name = Left(Part_Name, InStr(Part_Name, ".")-1)
End If
Dim New_Name As String = Part_Name
' '*******************remove line below to remove gauge from file name***********
New_Name = GA_Adder & " " & New_Name
' '*******************/remove line above to remove gauge from file name**********
Dim nameandpath As String = File_Location & "\" & GA_Adder & "\" & New_Name & Rev_Adder & ".dxf"
Dim oDataIO As DataIO = doc.ComponentDefinition.DataIO
oDataIO.WriteDataToFile("FLAT PATTERN DXF?AcadVersion=R12&RebaseGeometry=True&SimplifySpline=True&InteriorProfilesLayer=IV_INTERIOR_PROFILES&InvisibleLayers=IV_TANGENT;IV_BEND;IV_BEND_DOWN;IV_TOOL_CENTER_DOWN;IV_ARC_CENTERS;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES_DOWN;IV_UNCONSUMED_SKETCHES;IV_ROLL_TANGENT;IV_ROLL&SplineToleranceDouble=0.01",nameandpath)
End Sub
