Hi everyone,
although this question has been raised several times and I went through several posts - I still have issues with understanding how to get my Macro working. Currently, I am extremely thankful for the sushi sheet metal to dxf tool, which I found in another post here. This works fine with single parts, which I manually convert into Sheet metal parts, collect bends, and then run the macro. But once I am running the tool on the entire assembly it won´t work.
More about my current situation:
I receive step files and have to convert them to dxf for AutoCAD, the assembly needs to be "break link" first, then child parts need to be converted to sheet metal collecting all the bends considering the k factor as 0.4 mm, then flatten the converted part and save it to dxf along with options as bend lines selected,
sometimes child parts with chamfers won't get converted to sheet metal while collecting all the bends.
This entire process is very time-consuming and I believe there are many shortcuts I might have missed out.
thank you very much and please don't be to harsh on my limited knowledge.
best regards, Dennis
thank you Kevin 🙂
Option Explicit Global swApp As SldWorks.SldWorks Global swModel As SldWorks.ModelDoc2 Global SaveLocation As String Global DocNameAndExtension As String Global ExportDocName As String Global CurrentFolder As String Global RefPartFilePathName As String Global TempNewFolderName As String Global TempFolderSuffix As String Global SaveLocationSet As Boolean Global ParentFolderPath As String Global OriginalFolderPath As String Global OriginalPathName As String Global NewFolderName As String Global TotalsForExport As Integer Global CurrentForExportCount As Integer Global MappingFileLocation As String Global AltSaveLocation As String Global ConfigSuffix As String Global swFileType As String Global swExportType As String Global SingleStartConfig As String Global ExportConfigsArr As Variant Global ExportFilesArr As Variant Global FailedToExportArr As Variant Global CorrectBendsOnly As Boolean Global origDxfMapping As Boolean Global origDxfDontShowMap As Boolean Global origDxfVersion As Integer Global origDxfOutputFonts As Integer Global origDxfMappingFileIndex As Integer Global origDxfOutputLineStyles As Integer Global origDxfMappingFiles As String Global origDxfEndPointMerge As Boolean Global origDxfMergingDistance As Double Global origDxfHighQualityExport As Boolean Global origDxfExportSplinesAsSplines As Boolean 'true = splines. false = polylines Global ExpFilePosition(8) As Variant Global Const ConfiguratorConfig = "-CONFIG-" Global Const ConfiguratorPartName = "-PART NAME-" Global Const ConfiguratorThickness = "-THICKNESS-" Global Const ConfiguratorMaterial = "-MATERIAL-" Global Const ConfiguratorFlatFeat = "-FLAT-FEAT #-" Global MapFiles() As String Private Const SW_RESTORE = 9 #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function IsIconic Lib "user32.dll" (ByVal hWnd As Long) As Long Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else 'Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long 'Private Declare Function IsIconic Lib "user32.dll" (ByVal hwnd As Long) As Long #End If Public Function UpdateStatus(Status As String, StatusForeColor As String, Part As String, Config As String) frmStatus.lblStatus = Status frmStatus.lblStatus.ForeColor = StatusForeColor frmStatus.lblCurrentPart = Part frmStatus.lblCurrentConfig = Config frmStatus.Repaint End Function Sub MainRoutine() On Error Resume Next Dim TimeClock As Date Dim f As Long Dim DisplayText As String Dim CheckParamsResult As Variant Dim InitSwModel As String Dim p As Long Dim error As Boolean If frmControlPanel.optSingle = False And frmControlPanel.optBatch = False And frmControlPanel.optAssembly = False Then MsgBox "An 'Export Type' must be selected.", vbExclamation, "Export type required" Exit Sub End If Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc If swModel.GetPathName <> OriginalPathName Then MsgBox "Filename Mismatch. Changing files after initiating the " & _ "control panel is not allowed. Please rerun the Tool.", _ vbCritical + vbOKOnly, "Filename Mismatch" End End If CheckParamsResult = CheckFileAndExportType If frmControlPanel.Controls("cboPos" & (1)) = "" And _ frmControlPanel.Controls("cboPos" & (2)) = "" And _ frmControlPanel.Controls("cboPos" & (3)) = "" And _ frmControlPanel.Controls("cboPos" & (4)) = "" And _ frmControlPanel.Controls("cboPos" & (5)) = "" And _ frmControlPanel.Controls("cboPos" & (6)) = "" And _ frmControlPanel.Controls("cboPos" & (7)) = "" And _ frmControlPanel.Controls("cboPos" & (8)) = "" Then MsgBox "An export filename must be configured before running!", _ vbCritical + vbOKOnly, _ "No export filename" Exit Sub End If frmControlPanel.Hide frmStatus.Show TimeClock = Now mMain.UpdateStatus "Getting things ready...", RGB(0, 171, 25), "", "" frmStatus.lblStartTime.Caption = Format(Now, "h:mm am/pm") frmStatus.lblElapsedTime.Visible = False ConfigSuffix = frmControlPanel.txtConfigSuffix error = mMain.AddConfigsOrFilesToExportArr If error = True Then MsgBox "No configurations or files selected.", vbOKOnly + vbInformation, "No selection" Exit Sub End If 'main entry point If CheckParamsResult = error Then End ElseIf CheckParamsResult = "SLDPRT-SINGLE" Then Call InitPartSingle ElseIf CheckParamsResult = "SLDPRT-BATCH" Then Call InitPartBatch ElseIf CheckParamsResult = "SLDASM" Then Call InitAsmExport End If mMain.ResetDxfMap DisplayText = DisplayText & vbNewLine & "The export has successfully completed." DisplayText = DisplayText & vbNewLine & "Export elapsed time: " & Format(Now - TimeClock, "h:m:ss") & " (H:M:SS)" DisplayText = DisplayText & vbNewLine & vbNewLine If IsEmpty(FailedToExportArr) = False Then For f = 0 To UBound(FailedToExportArr) DisplayText = DisplayText & vbNewLine & FailedToExportArr(f) Next f End If frmStatus.lblElapsedTime = "Running Time: " & Format(Now - TimeClock, "h:m:ss") & " (H:M:SS)" frmStatus.lblElapsedTime.Visible = True frmStatus.lblStatus.Caption = "Export Complete!" frmStatus.lblStatus.ForeColor = RGB(33, 230, 33) frmStatus.lblCurrentPart.Caption = "" frmStatus.lblCurrentConfig.Caption = "" frmStatus.Repaint Unload frmStatus MsgBox DisplayText, vbOKOnly + vbInformation, "Export Complete" Unload frmControlPanel If Err.Number > 0 Then Debug.Print "MainRoutine " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub ConfigureList(Optional ClearList As Boolean = True) On Error Resume Next Dim intIndex As Integer Dim StartPickFolder As String Dim MyConfigs As Variant Dim MyConfig As SldWorks.Configuration Dim StartConfigMgr As SldWorks.ConfigurationManager Dim c As Long Dim e As Long Dim FileIsInList As Boolean Dim ConfigIsInList As Boolean Dim ConfigCount As Integer Dim FileCount As Integer Dim swStartConfig As SldWorks.Configuration Dim SelectedCount As Integer Dim i As Long Dim TempTitle As String Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc If swModel.GetPathName = "" Then MsgBox "Please save the file before exporting.", vbCritical, "Partname not found" End End If If ClearList = True Then frmControlPanel.listExportOptions.Clear frmControlPanel.listExportOptions.ListStyle = fmListStyleOption ReDim ExportFilesArr(0) End If If swModel.GetType = 1 Then If frmControlPanel.optSingle = True Then frmControlPanel.optBatch.Enabled = True frmControlPanel.optSingle.Enabled = True frmControlPanel.optAssembly = False frmControlPanel.chkSelectAll.Enabled = True frmControlPanel.listExportOptions.BackColor = vbWhite 'set the MyConfig to be returned to later Set swStartConfig = swModel.GetActiveConfiguration SingleStartConfig = swStartConfig.Name 'add configurations to list MyConfigs = swModel.GetConfigurationNames For c = 0 To UBound(MyConfigs) Set MyConfig = swModel.GetConfigurationByName(MyConfigs(c)) If frmControlPanel.optExportParentOnly = True Then If MyConfig.IsDerived = False Then frmControlPanel.listExportOptions.AddItem UCase((MyConfigs(c))) End If Else: frmControlPanel.listExportOptions.AddItem UCase((MyConfigs(c))) End If Next c 'select start config For intIndex = 0 To frmControlPanel.listExportOptions.ListCount - 1 If frmControlPanel.listExportOptions.List(intIndex) = swStartConfig.Name Then frmControlPanel.listExportOptions.Selected(intIndex) = True End If Next intIndex ElseIf frmControlPanel.optBatch = True Then 'add files in folder to list 'if folder options hide extensions... If UCase(Right(swModel.GetTitle, 6)) = "SLDPRT" Then TempTitle = UCase(swModel.GetTitle) Else TempTitle = UCase(swModel.GetTitle) & ".SLDPRT" End If StartPickFolder = Left(swModel.GetPathName, Len(swModel.GetPathName) - Len(TempTitle)) Debug.Print StartPickFolder Dim FSO As Scripting.FileSystemObject Set FSO = CreateObject("Scripting.FileSystemObject") Dim MyFiles As Scripting.Files Set MyFiles = FSO.GetFolder(StartPickFolder).Files Dim MyFile As Scripting.File 'add all prt files in folder to files array For Each MyFile In MyFiles If UCase(Right(MyFile.Name, 6)) = "SLDPRT" And UCase(Left(MyFile.Name, 1)) <> "~" Then If IsEmpty(ExportFilesArr) Then ReDim ExportFilesArr(0) FileCount = 0 End If 'if file is already in the list then do not re-add it For e = 0 To UBound(ExportFilesArr) If MyFile.Name = ExportFilesArr(e) Then FileIsInList = True End If Next e If FileIsInList = False Then FileCount = FileCount + 1 ReDim Preserve ExportFilesArr(FileCount) ExportFilesArr(FileCount) = UCase(MyFile.Name) frmControlPanel.listExportOptions.AddItem UCase(Right(MyFile, Len(MyFile) - Len(StartPickFolder))) End If End If Next MyFile 'select start part - this is the open part file For intIndex = 0 To frmControlPanel.listExportOptions.ListCount - 1 If frmControlPanel.listExportOptions.List(intIndex) = TempTitle Then frmControlPanel.listExportOptions.Selected(intIndex) = True End If Next intIndex ElseIf frmControlPanel.optAssembly = True Then frmControlPanel.optAssembly = False frmControlPanel.listExportOptions.Locked = True frmControlPanel.listExportOptions.BackColor = RGB(240, 240, 240) MsgBox "Assembly export can not be initiated on a .sldprt filetype.", _ vbExclamation + vbOKOnly, _ "Invalid export type" End If ElseIf swModel.GetType = 2 Then 'this code is dead because assembly opt button is disabled frmControlPanel.optBatch.Enabled = False frmControlPanel.optSingle.Enabled = False frmControlPanel.optAssembly = True frmControlPanel.chkSelectAll.Enabled = False frmControlPanel.listExportOptions.Clear frmControlPanel.listExportOptions.BackColor = RGB(240, 240, 240) End If For i = 0 To frmControlPanel.listExportOptions.ListCount - 1 If frmControlPanel.listExportOptions.Selected(i) = True Then SelectedCount = SelectedCount + 1 End If Next i If SelectedCount = frmControlPanel.listExportOptions.ListCount Then frmControlPanel.chkSelectAll = True Else frmControlPanel.chkSelectAll = False End If If Err.Number > 0 Then Debug.Print "ConfigureList " & "Err #" & Err.Number & " " & Err.Description End If End Sub Function AddConfigsOrFilesToExportArr() As Boolean On Error Resume Next Dim intIndex As Integer Dim count As Integer If frmControlPanel.optSingle = True Then ExportConfigsArr = Empty For intIndex = 0 To frmControlPanel.listExportOptions.ListCount - 1 If frmControlPanel.listExportOptions.Selected(intIndex) = True Then If IsEmpty(ExportConfigsArr) Then ReDim ExportConfigsArr(0) count = 0 Else: count = count + 1 ReDim Preserve ExportConfigsArr(count) End If ExportConfigsArr(count) = frmControlPanel.listExportOptions.List(intIndex) End If Next intIndex ElseIf frmControlPanel.optBatch = True Then ExportFilesArr = Empty For intIndex = 0 To frmControlPanel.listExportOptions.ListCount - 1 If frmControlPanel.listExportOptions.Selected(intIndex) = True Then If IsEmpty(ExportFilesArr) Then ReDim ExportFilesArr(0) count = 0 Else: count = count + 1 ReDim Preserve ExportFilesArr(count) End If ExportFilesArr(count) = frmControlPanel.listExportOptions.List(intIndex) End If Next intIndex End If 'If either array is empty then return error state If frmControlPanel.optSingle = True Then If ExportConfigsArr(0) = "" Then AddConfigsOrFilesToExportArr = True Else AddConfigsOrFilesToExportArr = False End If ElseIf frmControlPanel.optBatch = True Then If ExportFilesArr(0) = "" Then AddConfigsOrFilesToExportArr = True Else AddConfigsOrFilesToExportArr = False End If End If If Err.Number > 0 Then Debug.Print "AddConfigsOrFilesToExport " & "Err #" & Err.Number & " " & Err.Description End If End Function Function CheckFileAndExportType() As Variant On Error Resume Next Dim FileType As String Dim PathSize As Long Dim DocNameLength As Integer Dim TempTitle As String Set swModel = swApp.ActiveDoc FileType = swModel.GetType If UCase(Right(swModel.GetTitle, 6)) = ("SLDPRT" Or "SLDASM") Then TempTitle = swModel.GetTitle Else TempTitle = swModel.GetTitle & ".sldprt" End If DocNameLength = Strings.Len(TempTitle) PathSize = Strings.Len(swModel.GetPathName) ParentFolderPath = Strings.Left(swModel.GetPathName, PathSize - DocNameLength) 'has end-slash. Is changed in EstablishParameters when export location is custom Debug.Print "Parent Folder: " & ParentFolderPath If frmControlPanel.optSingle = True Then If FileType <> 1 Then '1 FOR SLDPRT MsgBox "'Single' export can only be run on a .SLDPRT file type." & _ vbNewLine & vbNewLine & _ "Please open a sheet-metal .SLDPRT file and re-run.", _ vbOKOnly + vbCritical, _ "Sheet-Metal part Required" CheckFileAndExportType = error Else CheckFileAndExportType = "SLDPRT-SINGLE" End If ElseIf frmControlPanel.optBatch = True Then If FileType <> 1 Then '1 FOR SLDPRT MsgBox "'Batch' export can only be initiated from a .SLDPRT file type." & _ vbNewLine & vbNewLine & _ "Please open a sheet-metal .SLDPRT file and re-run.", _ vbOKOnly + vbCritical, _ "Sheet-Metal part Required" CheckFileAndExportType = error Else CheckFileAndExportType = "SLDPRT-BATCH" End If ElseIf frmControlPanel.optAssembly = True Then If FileType <> 2 Then '2 FOR SLDASM MsgBox "'Assembly' export can only be initiated from a .SLDASM file type." & _ vbNewLine & vbNewLine & _ "Please open a .SLDASM file and re-run.", _ vbOKOnly + vbCritical, _ "Assembly Required" CheckFileAndExportType = error Else CheckFileAndExportType = "SLDASM" End If End If swExportType = CheckFileAndExportType If Err.Number > 0 Then Debug.Print "CheckFileAndExportType " & "Err #" & Err.Number & " " & Err.Description End If End Function Private Function CheckSheetMetal(ModelDoc As SldWorks.ModelDoc2, _ Optional FromExportAction As Boolean = False, _ Optional ParentFeatName As String = "", _ Optional Config As String = "", _ Optional ParentFeatType As String = "") As Collection On Error Resume Next Dim swFeat As SldWorks.Feature Dim swSubFeat As SldWorks.BodyFolder Dim swSubSubFeat As SldWorks.Feature Dim swSheetMetal As SldWorks.SheetMetalFeatureData Dim Conversion As Double Dim ChildFeatures As Variant Dim FlatFeatData As SldWorks.FlatPatternFeatureData Dim SheetFeatData As SldWorks.SheetMetalFeatureData Dim subChild As SldWorks.Feature Dim Body As SldWorks.Body2 Dim featMgr1 As SldWorks.FeatureManager Dim i As Long Dim u As Long Dim BodyFolder As SldWorks.BodyFolder Dim BodyArr As Variant Dim FeatureArr As Variant Dim FeatMgr As SldWorks.FeatureManager Dim LocalFeat As SldWorks.Feature Dim SheetData As SldWorks.SheetMetalFeatureData Dim SolidBodies As SldWorks.BodyFolder Dim SolidBodiesArr As Variant Dim SolidBody() As SldWorks.Body2 Dim BodySelect As SldWorks.Body2 Dim swSelData As SldWorks.selectData Dim swCutlistFeat As Feature Dim swFeatMgr As SldWorks.FeatureManager Dim b As Long Dim swSelMgr As SldWorks.SelectionMgr Dim x As Long Dim sMatDb As String Dim CurPart As SldWorks.PartDoc Dim SheetInfo As New clsSheetInfo Dim ThicknessTemp As Double Dim Material As String Set swSelMgr = ModelDoc.SelectionManager Set swFeatMgr = ModelDoc.FeatureManager Set SheetInfo.Sheet = New Collection Set CurPart = ModelDoc Set swFeat = ModelDoc.FirstFeature While Not swFeat Is Nothing Debug.Print "-----------------------------" Debug.Print "Feature Name: " & swFeat.Name Debug.Print " Type: " & swFeat.GetTypeName2 'search Solidbody folder and add all non cutlist items to cutlist as cutlist items If FromExportAction = False Then If swFeat.GetTypeName2 = "SolidBodyFolder" Then Set SolidBodies = swFeat.GetSpecificFeature2 SolidBodiesArr = SolidBodies.GetBodies If Not IsEmpty(SolidBodiesArr) Then For b = 0 To UBound(SolidBodiesArr) Set BodySelect = SolidBodiesArr(b) If BodySelect.isSheetMetal = False Then GoTo NextFeature End If Set swSelData = swSelMgr.CreateSelectData BodySelect.Select2 True, swSelData Set swCutlistFeat = swFeatMgr.InsertWeldmentCutList Next b End If End If End If 'search cutlist items and if sheetmetal then get thickness 'if not sheetmetal then skip If swFeat.GetTypeName = "CutListFolder" Then Set BodyFolder = swFeat.GetSpecificFeature2 BodyFolder.SetAutomaticCutList True BodyFolder.SetAutomaticUpdate True BodyFolder.UpdateCutList BodyArr = BodyFolder.GetBodies 'if no features exist, as with "inserted parts" then skip If IsEmpty(BodyArr) Then GoTo NextFeature Else For x = 0 To UBound(BodyArr) Set Body = BodyArr(x) Debug.Print Body.Name If Body.isSheetMetal = False Then GoTo NextFeature End If Next x End If For i = 0 To UBound(BodyArr) Set Body = BodyArr(i) Debug.Print " Body Name: " & Body.Name FeatureArr = Body.GetFeatures 'there can be multiple bodies in the bodyarr For u = 0 To UBound(FeatureArr) Set LocalFeat = FeatureArr(u) If LocalFeat.GetTypeName2 = "SheetMetal" Then Debug.Print " SheetMetal Feature Name: " & LocalFeat.Name Set SheetData = LocalFeat.GetDefinition ThicknessTemp = SheetData.Thickness Conversion = 1000 ThicknessTemp = (ThicknessTemp * Conversion) / 25.4 Debug.Print " Thickness is: " & ThicknessTemp & " in" Material = CurPart.GetMaterialPropertyName2(Config, sMatDb) Debug.Print Material 'add thickness and material to sheetinfo sheet collection If SheetInfo.Sheet.count > 0 Then SheetInfo.Sheet.Remove (1) SheetInfo.Sheet.Remove (1) End If SheetInfo.Sheet.Add ThicknessTemp SheetInfo.Sheet.Add Material Set CheckSheetMetal = SheetInfo.Sheet If frmControlPanel.optExportAllBodies = False Then GoTo ExitCheck End If End If If FromExportAction = True Then Debug.Print LocalFeat.Name If LocalFeat.GetTypeName2 = ParentFeatType Then 'Or LocalFeat.GetTypeName2 = "FlatPattern" Then If ParentFeatName = LocalFeat.Name Then GoTo ExitCheck End If End If End If Next u Next i End If NextFeature: Set swFeat = swFeat.GetNextFeature Wend ExitCheck: If Err.Number > 0 Then Debug.Print "CheckSheetMetal " & "Err #" & Err.Number & " " & Err.Description End If End Function Sub InitPartSingle() On Error Resume Next Dim vConfigNameArr As Variant Dim vConfigName As Variant Dim SheetMetalExists As Boolean Dim i As Long Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc For i = 0 To UBound(ExportConfigsArr) If Not IsEmpty(ExportConfigsArr(i)) Then TotalsForExport = TotalsForExport + 1 End If Next i vConfigNameArr = swModel.GetConfigurationNames For Each vConfigName In vConfigNameArr If CheckSheetMetal(swModel).item(1) <> 0 Then SheetMetalExists = True End If Next If SheetMetalExists = True Then Call InitPartCycleConfigs Else 'the value of function return CheckSheetMetal is the thickness of the material as a Double MsgBox "The file is not a sheet-metal part!" & _ vbNewLine & vbNewLine & _ "Please open a sheet-metal part and re-run.", _ vbOKOnly + vbCritical, _ "Sheet-Metal part Required" End End If If Err.Number > 0 Then Debug.Print "InitPartSingle " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub InitPartBatch() On Error Resume Next Dim FSO As Scripting.FileSystemObject Dim MyFiles As Scripting.Files Dim MyFile As Scripting.File Dim error As SldWorks.ModelDoc2 Dim Errors As Long Dim Warnings As Long Dim i As Long Dim FileFound As Boolean Dim f As Long Set FSO = CreateObject("Scripting.FileSystemObject") Set MyFiles = FSO.GetFolder(ParentFolderPath).Files 'Get total files in folder For f = 0 To UBound(ExportFilesArr) If Not IsEmpty(ExportFilesArr(f)) Then TotalsForExport = TotalsForExport + 1 End If Next f 'iterate through files in the parent folder until finding the current part For Each MyFile In MyFiles If swExportType = "SLDPRT-BATCH" Then swApp.CloseAllDocuments (True) 'SaveLocationSet = False For i = 0 To UBound(ExportFilesArr) If UCase(MyFile.Name) = ExportFilesArr(i) Then FileFound = True End If Next i 'If UCase(Right(MyFile.Name, 6)) = "SLDPRT" And UCase(Left(MyFile.Name, 1)) <> "~" Then If FileFound = True Then mMain.UpdateStatus "Getting a new part ready...", vbRed, MyFile.Name, "" swApp.OpenDoc6 MyFile.Path, swDocPART, 0, "", Errors, Warnings If Errors > 0 Then FileFound = False GoTo NextFile End If Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc If CheckSheetMetal(swModel).item(1) = 0 Then swApp.CloseDoc (MyFile.Name) GoTo NextFile Else: CurrentForExportCount = CurrentForExportCount + 1 Call InitPartCycleConfigs End If FileFound = False Else: GoTo NextFile End If End If NextFile: Next MyFile If Err.Number > 0 Then Debug.Print "InitPartBatch " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub InitPartCycleConfigs() On Error Resume Next Dim swConfig As SldWorks.Configuration Dim swConfigArr As Variant Dim swFeatMgr As SldWorks.FeatureManager Dim sConfigName As String Dim InitConfig As SldWorks.Configuration Dim FileOrConfig As String Dim x As Long Dim y As Long Dim TempCfgCount As Integer Set swFeatMgr = swModel.FeatureManager swFeatMgr.EditRollback swMoveRollbackBarToEnd, "" mMain.FindReplaceCharactersInConfig mMain.EstablishParameters If CorrectBendsOnly = False Then mMain.GenExportFolder End If If frmControlPanel.chkAddConfigSuffix = True Then mMain.UpdateStatus "Adding configuration suffix...", vbBlue, "", "" mMain.AddRemoveConfigSuffix (True) 'adds suffix to all configs End If swConfigArr = swModel.GetConfigurationNames Set InitConfig = swModel.GetActiveConfiguration For x = 0 To UBound(swConfigArr) Set swConfig = swModel.GetConfigurationByName(swConfigArr(x)) If frmControlPanel.optSingle = True Then For y = 0 To UBound(ExportConfigsArr) If UCase(Left(swConfig.Name, Len(swConfig.Name) - Len(ConfigSuffix))) = UCase(ExportConfigsArr(y)) Then sConfigName = swConfigArr(x) swModel.ShowConfiguration2 sConfigName CurrentForExportCount = CurrentForExportCount + 1 Call ExportAction(swConfig, swModel) End If Next y ElseIf frmControlPanel.optBatch = True Then If frmControlPanel.optExportParentOnly = True Then If swConfig.IsDerived <> False Then GoTo SkipConfig End If End If GoForExport: 'on the first pass, redim the array If x = 0 Then ReDim ExportConfigsArr(0) End If 'populate the array with config names for deletion in ref part purpose ExportConfigsArr(TempCfgCount) = swConfigArr(x) TempCfgCount = TempCfgCount + 1 ReDim Preserve ExportConfigsArr(TempCfgCount) sConfigName = swConfigArr(x) swModel.ShowConfiguration2 sConfigName Call ExportAction(swConfig, swModel) End If SkipConfig: Next x If frmControlPanel.chkAddRefPart Or frmControlPanel.chkSaveOriginalPart = True Then swModel.ShowConfiguration2 InitConfig.Name End If If frmControlPanel.chkAddRefPart = True Then mMain.SaveRefPart End If If frmControlPanel.chkAddConfigSuffix = True Then mMain.AddRemoveConfigSuffix (False) 'removes suffix from all configs End If 'Choose file save If frmControlPanel.chkSaveOriginalPart = True Then mMain.UpdateStatus "Saving original part file with bend corrections...", vbBlue, swModel.GetTitle, "" swModel.ShowConfiguration2 InitConfig.Name swModel.SaveAs3 swModel.GetPathName, swSaveAsCurrentVersion, swSaveAsOptions_Silent SaveLocationSet = False End If If frmControlPanel.optSingle <> True Then swApp.CloseDoc (swModel.GetPathName) End If If Err.Number > 0 Then Debug.Print "InitPartCycleConfigs " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub InitAsmExport() On Error Resume Next Dim swApp As SldWorks.SldWorks Dim swModel As SldWorks.ModelDoc2 Dim swAssy As SldWorks.AssemblyDoc Dim swConf As SldWorks.Configuration Dim swRootComp As SldWorks.Component2 Dim nStart As Single Dim CountModelDoc As SldWorks.AssemblyDoc Dim i As Long Dim CountComps As Variant Dim CountComp As SldWorks.Component2 Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc Set swConf = swModel.GetActiveConfiguration Set swRootComp = swConf.GetRootComponent3(True) Set CountModelDoc = swModel Call EstablishParameters If CorrectBendsOnly = False Then Call GenExportFolder End If Debug.Print "File = " & swModel.GetPathName CountComps = CountModelDoc.GetComponents(False) 'true to get top level, false to get all levels For i = 0 To UBound(CountComps) Set CountComp = CountComps(i) If CountComp.IsSuppressed = False Then TotalsForExport = TotalsForExport + 1 End If Next i TraverseComponent swRootComp, 1 If frmControlPanel.chkSaveOriginalPart = True Then swModel.SaveAs3 swModel.GetPathName, swSaveAsCurrentVersion, swSaveAsOptions_Silent End If swApp.CloseDoc swModel.GetPathName If frmControlPanel.chkAddRefPart = True Then mMain.SaveAsmComponents End If Debug.Print "Finished!" If Err.Number > 0 Then Debug.Print "InitAsmExport " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long) On Error Resume Next Dim vChildComp As Variant 'Dim swApp As SldWorks.SldWorks Dim swPart As SldWorks.PartDoc Dim swChildComp As SldWorks.Component2 Dim swConfig As SldWorks.Configuration Dim swConfMgr As SldWorks.ConfigurationManager Dim swChildModel As SldWorks.ModelDoc2 Dim swOpenModel As SldWorks.ModelDoc2 Dim swChildCustPropMngr As CustomPropertyManager Dim swChildModelDocExt As ModelDocExtension Dim swSheetMetal As SldWorks.SheetMetalFeatureData Dim swFeat As SldWorks.Feature Dim swBody As SldWorks.Body2 Dim Sheet_metal As Boolean Dim Boolstatus As Boolean Dim conv As Double Dim i As Long Dim loptions As Long Dim lerrors As Long Dim sPadStr As String Dim FilePath As String Dim FileName As String Dim CompFilePath As String Dim swThkDir As String Dim swMatDir As String Dim swCurrent As String Dim RefCfg As String Dim ChildConfigName As String Dim sMatName As String Dim sMatDb As String Dim exFileName As String Dim Bodies As Variant Dim x As Long Dim SheetMetalFound As Boolean Dim SheetThickness As Double Dim FlatFeatData As SldWorks.FlatPatternFeatureData Dim FlatFace As SldWorks.Face2 Dim FlatFaceParentFeat As SldWorks.Feature Dim CompConfig As SldWorks.Configuration Dim tempModelDoc As SldWorks.ModelDoc2 Dim ExpCompsArr As Variant Dim ExportedCompCfgsArr As Variant Dim FileCount As Integer Dim ConfigCount As Integer Dim f As Long Dim c As Long Debug.Print swComp.Name & " L=" & nLevel vChildComp = swComp.GetChildren For i = 0 To UBound(vChildComp) Set swChildComp = vChildComp(i) Debug.Print swChildComp.Name If swChildComp.IsSuppressed = False Then GoTo Active Else GoTo skip Active: Set swApp = Application.SldWorks Set swChildModel = swChildComp.GetModelDoc2 If (swChildModel.GetType <> swDocPART) Then GoTo Jump 'Skips Subassemby level End If Set swPart = swChildModel 'Applies part commands for current component CompFilePath = swChildModel.GetPathName FilePath = Left(swComp.GetPathName, InStrRev(swComp.GetPathName, "\") - 1) FileName = swChildModel.GetTitle 'Get title of component swCurrent = swChildComp.ReferencedConfiguration 'Get current configuration of component 'Search for sheet metal body Bodies = swPart.GetBodies2(swBodyType_e.swAllBodies, True) For x = 0 To UBound(Bodies) Set swBody = Bodies(x) Debug.Print swBody.Name If swBody.isSheetMetal = 1 Then SheetMetalFound = True End If Next x If SheetMetalFound = True Then Debug.Print "Processing component " & FileName & " as a sheet metal component" Debug.Print "Current Config is : "; swCurrent GoTo Process Else GoTo Jump End If Process: 'The first part found is processed for export without processing for SKIP decision If Not IsEmpty(ExpCompsArr) Then 'initializes empty. line skip on first pass. When all other new parts are found, on first pass, they do not result in SKIP For f = 0 To UBound(ExpCompsArr) 'iterate through array (on first pass only has the first component found added) If UCase(ExpCompsArr(f)) = UCase(CompFilePath) Then For c = 0 To UBound(ExportedCompCfgsArr) If Not IsEmpty(ExportedCompCfgsArr) Then If UCase(ExportedCompCfgsArr(c)) = UCase(swCurrent) Then GoTo skip End If End If Next c End If Next f End If 'fill the export file array with the current filename If IsEmpty(ExpCompsArr) Then ReDim ExpCompsArr(FileCount) ExpCompsArr(FileCount) = CompFilePath Else FileCount = FileCount + 1 ReDim Preserve ExpCompsArr(FileCount) ExpCompsArr(FileCount) = CompFilePath End If 'fill the export config array with the current config name If IsEmpty(ExportedCompCfgsArr) Then ReDim ExportedCompCfgsArr(ConfigCount) ExportedCompCfgsArr(ConfigCount) = swCurrent Else ConfigCount = ConfigCount + 1 ReDim Preserve ExportedCompCfgsArr(ConfigCount) ExportedCompCfgsArr(ConfigCount) = swCurrent End If 'open the sldprt file for export Set swPart = swChildModel Set swOpenModel = swApp.ActivateDoc3(swChildModel.GetPathName, True, loptions, lerrors) Boolstatus = swChildModel.ShowConfiguration2(swCurrent) Set CompConfig = swChildModel.GetActiveConfiguration Set tempModelDoc = swApp.ActiveDoc Debug.Print CheckSheetMetal(tempModelDoc).item(1) 'this line ensures that sheetmetal bodies are added to the cutlist 'add config suffix If frmControlPanel.chkAddConfigSuffix = True Then AddRemoveConfigSuffix True, swCurrent End If CurrentForExportCount = CurrentForExportCount + 1 ExportAction CompConfig, swChildModel 'bend correction and body export is handled in ExportAction 'the suffix must be removed or the renamed config will throw this process If frmControlPanel.chkAddConfigSuffix = True Then AddRemoveConfigSuffix False, swCurrent & ConfigSuffix End If 'save part with bend correction if requested If frmControlPanel.chkSaveOriginalPart = True Then swChildModel.SaveAs3 swChildModel.GetPathName, swSaveAsCurrentVersion, swSaveAsOptions_Silent End If swApp.CloseDoc (swChildModel.GetPathName) GoTo Jump skip: Debug.Print "Skipped" Jump: TraverseComponent swChildComp, nLevel + 1 Next i ExportFilesArr = Null ExportConfigsArr = Null ExportFilesArr = ExpCompsArr ExportConfigsArr = ExportedCompCfgsArr If Err.Number > 0 Then Debug.Print "TraverseComponent" & "Err #" & Err.Number & " " & Err.Description End If End Sub Function SaveAsmComponents() On Error Resume Next Dim b As Long Dim g As Long Dim x As Long Dim FirstSlash As Integer Dim swCurrent As String Dim ExportedFiles As Variant Dim ExpFilesCount As Integer Dim IsExported As Boolean For b = 0 To UBound(ExportFilesArr) If IsEmpty(ExportedFiles) <> True Then For x = 0 To UBound(ExportedFiles) If UCase(ExportedFiles(x)) = UCase(ExportFilesArr(b)) Then IsExported = True End If Next x End If If IsExported = True Then GoTo SkipFile End If swApp.OpenDoc6 ExportFilesArr(b), swDocPART, swOpenDocOptions_Silent, "", 1, 1 Set swModel = swApp.ActiveDoc If IsEmpty(ExportedFiles) = True Then ReDim ExportedFiles(0) ExportedFiles(0) = ExportFilesArr(b) Else ExpFilesCount = ExpFilesCount + 1 ReDim Preserve ExportedFiles(ExpFilesCount) ExportedFiles(ExpFilesCount) = ExportFilesArr(b) End If FirstSlash = InStrRev(ExportFilesArr(b), "\", -1) RefPartFilePathName = SaveLocation & "\" & Right(ExportFilesArr(b), Len(ExportFilesArr(b)) - FirstSlash) & " (REF)" & ConfigSuffix & ".SLDPRT" Debug.Print "RefPartFileName: " & RefPartFilePathName For g = 0 To UBound(ExportConfigsArr) swCurrent = ExportConfigsArr(g) If frmControlPanel.chkAddConfigSuffix = True And frmControlPanel.chkRenameConfigs = True Then AddRemoveConfigSuffix True, swCurrent End If Next g mMain.SaveRefPart swApp.CloseDoc ExportFilesArr(b) SkipFile: Next b If Err.Number > 0 Then Debug.Print "SaveAsmComponents " & "Err #" & Err.Number & " " & Err.Description End If End Function Sub EstablishParameters() On Error Resume Next mMain.UpdateStatus "Establishing Parameters...", vbBlue, ExportDocName, "" Dim PathNoFilename As String Dim NameLength As Integer ExportDocName = swModel.GetTitle If UCase(Right(ExportDocName, 6)) = ("SLDPRT" Or "SLDASM") Then ExportDocName = Left(swModel.GetTitle, Len(swModel.GetTitle) - 7) Else ExportDocName = Left(swModel.GetTitle, Len(swModel.GetTitle)) End If TempFolderSuffix = 0 NewFolderName = "FP-" & ExportDocName TempNewFolderName = NewFolderName & "_" & TempFolderSuffix 'adjust location in GenExportFolder If Len(AltSaveLocation) > 1 Then SaveLocation = AltSaveLocation & NewFolderName & "_" & TempFolderSuffix 'adjust location in GenExportFolder - this is the save to folder Else SaveLocation = ParentFolderPath & NewFolderName & "_" & TempFolderSuffix 'adjust location in GenExportFolder - this is the save to folder End If If Err.Number > 0 Then Debug.Print "EstablishParameters " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub GenExportFolder() On Error GoTo GenFolderError Dim strFolderName As String Dim strFolderExists As String mMain.UpdateStatus "Setting up the export folder", vbBlue, ExportDocName, "" ReRunSave: If SaveLocationSet = False Then If Len(AltSaveLocation) > 1 Then SaveLocation = AltSaveLocation & NewFolderName & "_" & TempFolderSuffix 'adjust location in establishParameters Else SaveLocation = ParentFolderPath & NewFolderName & "_" & TempFolderSuffix 'adjust location in establishParameters End If ParentFolderPath = Left(SaveLocation, Len(SaveLocation) - Len(TempNewFolderName)) TempNewFolderName = NewFolderName & "_" & TempFolderSuffix 'adjust location in establishParameters End If strFolderName = SaveLocation strFolderExists = Dir(strFolderName, vbDirectory) Debug.Print "savelocation: " & SaveLocation If strFolderExists = "" Then RefPartFilePathName = SaveLocation & "\" & ExportDocName & " (REF)" & ConfigSuffix & ".SLDPRT" SaveLocationSet = True Debug.Print RefPartFilePathName Else TempFolderSuffix = TempFolderSuffix + 1 'this will update exportchild variable SaveLocationSet = False GoTo ReRunSave End If MkDir SaveLocation If frmControlPanel.chkOpenExpFolder = True Then mMain.OpenFolder SaveLocation End If GenFolderError: If Err.Number = 75 Then TempFolderSuffix = TempFolderSuffix + 1 GoTo ReRunSave ElseIf Err.Description <> "" Then MsgBox "GenExportFolder " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub SaveRefPart() On Error Resume Next Dim SaveFile As String mMain.UpdateStatus "Saving the REF. part file(s)", vbBlue, "", "" frmStatus.lblElapsedTime = "" SaveFile = swModel.SaveAs2(RefPartFilePathName, _ swSaveAsCurrentVersion, _ True, _ True) If SaveFile <> 0 Then Debug.Print "FILE SAVE ERROR" End If Set swModel = swApp.OpenDoc6(RefPartFilePathName, swDocPART, swOpenDocOptions_Silent, "", 1, 1) If frmControlPanel.chkDeleteSmFlatConfigs = True Then mMain.DeleteRefPartConfigs End If If frmControlPanel.chkDeleteDesignTable = True Then mMain.DeleteDesignTable End If Set swModel = swApp.ActiveDoc SaveFile = swModel.SaveAs2(RefPartFilePathName, _ swSaveAsCurrentVersion, _ True, _ True) swApp.CloseDoc (RefPartFilePathName) Set swModel = swApp.ActiveDoc If Err.Number > 0 Then Debug.Print "SaveRefPart " & "Err #" & Err.Number & " " & Err.Description End If End Sub Public Function OpenFolder(strDirectory As String) 'DESCRIPTION: Open folder if not already open. Otherwise, activate the already opened window 'DEVELOPER: Ryan Wells (wellsr.com) On Error Resume Next mMain.UpdateStatus "Opening export folder location", vbBlue, "", "" Dim w As Variant Dim pID As Variant Dim sh As Variant Dim Path As String Set sh = CreateObject("shell.application") For Each w In sh.Windows If w.Name = "Windows Explorer" Or w.Name = "File Explorer" Then If w.Document.Folder.Self.Path = strDirectory Then 'if already open, bring it front If CBool(IsIconic(w.hWnd)) Then ' If it's minimized, show it w.Visible = False w.Visible = True ShowWindow w.hWnd, SW_RESTORE Else w.Visible = False w.Visible = True End If Exit Function End If End If Next 'if you get here, the folder isn't open so open it 'Shell("explorer.exe """ & "C:\" & "", vbNormalFocus) pID = shell("explorer.exe """ & strDirectory & "", vbNormalFocus) If Err.Number > 0 Then Debug.Print "OpenFolder " & "Err #" & Err.Number & " " & Err.Description End If End Function Private Function ExportAction(ConfigObj As SldWorks.Configuration, ModelDoc As SldWorks.ModelDoc2) On Error Resume Next Dim sModelName As String Dim sPathName As String Dim swPart As SldWorks.PartDoc Dim options As Long Dim sDwgOrDxf As String Dim Index As Boolean Dim FlatFeatNum As Integer Dim DxfMappingFileIndex As Integer Dim DxfMapFileLoc As Boolean Dim SheetThickness As Double Dim Conversion As Double Dim swFeat As SldWorks.Feature Dim swSelMgr As SldWorks.SelectionMgr Dim swConfiMgr As SldWorks.ConfigurationManager Dim swConfig As SldWorks.Configuration Dim ExpConfigName As String Dim ExportFailed As Boolean Dim FailCount As Integer Dim varViews As Variant Dim dataViews(0) As String Dim FlatFeatData As SldWorks.FlatPatternFeatureData Dim FlatFace As SldWorks.Face2 Dim FlatFaceParentFeat As SldWorks.Feature Dim FlatParentFeatType As String Dim IsSmFlatConfig As Boolean Dim swMatDir As String Dim swThkDir As String Dim sMatName As String Dim FileName As String Dim swCurrent As String Dim PathLength As Integer Dim p As Long Dim Bit(1 To 12) As Integer Dim BendLineOptions As Integer Dim b As Integer frmStatus.lblElapsedTime.Caption = "Exporting... " & CurrentForExportCount & " of " & TotalsForExport frmStatus.lblElapsedTime.Visible = True frmStatus.Repaint Set swPart = ModelDoc If frmControlPanel.optDWG.Value = True Then sDwgOrDxf = ".DWG" ElseIf frmControlPanel.optDXF = True Then sDwgOrDxf = ".DXF" End If BendLineOptions = 0 Bit(1) = 1 'to export flat-pattern geometry; 0 to not Bit(2) = 2 'to include hidden edges; 0 to not Bit(3) = 4 'to export bend lines; 0 to not Bit(4) = 8 'to include sketches; 0 to not Bit(5) = 16 'to merge coplanar faces; 0 to not Bit(6) = 32 'to export library features; 0 to not Bit(7) = 64 'to export forming tools; 0 to not Bit(8) = 128 Bit(9) = 256 Bit(10) = 512 Bit(11) = 1024 Bit(12) = 2048 'to export bounding box; 0 to not For b = 1 To 12 If b = 5 Or b = 8 Or b = 9 Or b = 10 Or b = 11 Then GoTo SkipBit Else If frmControlPanel.Controls("chkBit" & (b)) = True Then BendLineOptions = BendLineOptions + Bit(b) End If End If SkipBit: Next b Debug.Print "BendLineOptions: " & BendLineOptions Set swConfiMgr = ModelDoc.ConfigurationManager Set swConfig = swConfiMgr.ActiveConfiguration Set swSelMgr = ModelDoc.SelectionManager Set swFeat = ModelDoc.FirstFeature sModelName = ModelDoc.GetPathName dataViews(0) = "Flat pattern" varViews = dataViews 'do loops through all flat pattern features Do Until swFeat Is Nothing If swFeat.GetTypeName = "FlatPattern" Then Debug.Print swFeat.Name 'skip flat-pattern feature if its suppressed in flat pattern configuration If InStr(1, UCase(ConfigObj.Name), UCase("SM-Flat-Pattern"), vbTextCompare) > 0 Then IsSmFlatConfig = True If swFeat.IsSuppressed <> False Then GoTo SkipFlatFeature End If End If Set FlatFeatData = swFeat.GetDefinition Set FlatFace = FlatFeatData.FixedFace2 Set FlatFaceParentFeat = FlatFace.GetFeature FlatParentFeatType = FlatFaceParentFeat.GetTypeName Debug.Print swFeat.Name Debug.Print FlatFaceParentFeat.Name Debug.Print FlatFaceParentFeat.GetTypeName SheetThickness = CheckSheetMetal(ModelDoc, True, FlatFaceParentFeat.Name, "", FlatParentFeatType).item(1) sMatName = CheckSheetMetal(ModelDoc, True, FlatFaceParentFeat.Name, ConfigObj.Name, FlatParentFeatType).item(2) If SheetThickness = 0 Then GoTo SkipFlatFeature End If 'if selected, run Correct Bend Suppression If frmControlPanel.chkFlatBendCorrection = True Then mMain.UpdateStatus "Correcting bends...", vbRed, ModelDoc.GetTitle, ConfigObj.Name Call mMain.CorrectBendSuppression(ConfigObj, IsSmFlatConfig, swFeat.Name) End If If CorrectBendsOnly = False Then FlatFeatNum = Right(swFeat.Name, Len(swFeat.Name) - Len("Flat-Pattern")) If frmControlPanel.chkRenameConfigs = True Then ExpConfigName = ConfigObj.Name Else If frmControlPanel.chkAddConfigSuffix = True Then ExpConfigName = Left(ConfigObj.Name, Len(ConfigObj.Name) - Len(ConfigSuffix)) End If End If 'Make material and thickness directories swMatDir = SaveLocation & "\" & sMatName & "\" Debug.Print swMatDir If Dir(swMatDir, vbDirectory) = "" Then MkDir swMatDir swThkDir = SaveLocation & "\" & sMatName & "\" & SheetThickness Debug.Print swThkDir If Dir(swThkDir, vbDirectory) = "" Then MkDir swThkDir GetSetCustPropFileNames ModelDoc, ConfigObj.Name For p = 1 To 8 Debug.Print frmControlPanel.Controls("cboPos" & (p)) If frmControlPanel.Controls("cboPos" & (p)) = ConfiguratorConfig Then ExpFilePosition(p) = ExpConfigName & "_" ElseIf frmControlPanel.Controls("cboPos" & (p)) = ConfiguratorFlatFeat Then ExpFilePosition(p) = "FP-" & FlatFeatNum & "_" ElseIf frmControlPanel.Controls("cboPos" & (p)) = ConfiguratorPartName Then ExpFilePosition(p) = ExportDocName & "_" ElseIf frmControlPanel.Controls("cboPos" & (p)) = ConfiguratorMaterial Then ExpFilePosition(p) = sMatName & "_" ElseIf frmControlPanel.Controls("cboPos" & (p)) = ConfiguratorThickness Then ExpFilePosition(p) = SheetThickness & "in_" Else If frmControlPanel.Controls("cboPos" & (p)) = "" Then ExpFilePosition(p) = "" Else ExpFilePosition(p) = frmControlPanel.Controls("cboPos" & (p)) & "_" End If End If Next p 'update export final location sPathName = ExpFilePosition(1) & _ ExpFilePosition(2) & _ ExpFilePosition(3) & _ ExpFilePosition(4) & _ ExpFilePosition(5) & _ ExpFilePosition(6) & _ ExpFilePosition(7) & _ ExpFilePosition(8) PathLength = Len(sPathName) sPathName = Left(sPathName, PathLength - 1) sPathName = SaveLocation & "\" & sMatName & "\" & SheetThickness & "\" & sPathName & sDwgOrDxf Debug.Print "Export Path Name: " & sPathName mMain.UpdateStatus "Exporting configuration...", RGB(0, 171, 25), ModelDoc.GetTitle, ConfigObj.Name & " (Flat-Pattern" & FlatFeatNum & ")" ModelDoc.EditRebuild3 swFeat.Select True If frmControlPanel.optExportAnnotationFlat = True Then If swPart.ExportToDWG2(sPathName, sModelName, swExportToDWG_ExportAnnotationViews, False, Empty, False, False, BendLineOptions, varViews) <> False Then Debug.Print "Successfully exported --: " & ExpConfigName Debug.Print "Path -------------------: " & sPathName Else Debug.Print "Export failed ----------: " & ExpConfigName Debug.Print "Path: ------------------: " & sPathName ExportFailed = True End If Else If swPart.ExportToDWG2(sPathName, sModelName, swExportToDWG_ExportSheetMetal, True, Empty, False, False, BendLineOptions, Null) <> False Then Debug.Print "Successfully exported --: " & ExpConfigName Debug.Print "Path -------------------: " & sPathName Else Debug.Print "Export failed ----------: " & ExpConfigName Debug.Print "Path: ------------------: " & sPathName ExportFailed = True End If End If If ExportFailed = True Then If IsEmpty(FailedToExportArr) Then FailCount = 0 ReDim FailedToExportArr(FailCount) FailedToExportArr(FailCount) = "Export failed for configurations:" FailCount = FailCount + 1 ReDim Preserve FailedToExportArr(FailCount) FailedToExportArr(FailCount) = ConfigObj.Name & " (FP-" & FlatFeatNum & ")" Else: FailCount = FailCount + 1 ReDim Preserve FailedToExportArr(FailCount) FailedToExportArr(FailCount) = ConfigObj.Name & " (FP-" & FlatFeatNum & ")" End If ExportFailed = False End If 'if not multibody export, exit the loop If frmControlPanel.optExportAllBodies = False Then GoTo ExitLoop End If End If End If SkipFlatFeature: Set swFeat = swFeat.GetNextFeature Loop ExitLoop: If Err.Number > 0 Then Debug.Print "ExportAction " & "Err #" & Err.Number & " " & Err.Description End If End Function Sub GetSetCustPropFileNames(ModelDoc As SldWorks.ModelDoc2, Config As String) On Error Resume Next Dim swCustPropMgr As SldWorks.CustomPropertyManager Dim vCustPropNames As Variant Dim vConfigNamesArray As Variant Dim vConfigName As Variant Dim vName As Variant Dim valOut As String Dim strValue As String Dim p As Long Set swCustPropMgr = ModelDoc.Extension.CustomPropertyManager(Empty) vCustPropNames = swCustPropMgr.GetNames If IsEmpty(vCustPropNames) = False Then For Each vName In vCustPropNames swCustPropMgr.Get3 vName, True, valOut, strValue For p = 1 To 8 If UCase(frmControlPanel.Controls("cboPos" & (p))) = UCase(vName) And _ vName <> ConfiguratorConfig And _ vName <> ConfiguratorPartName And _ vName <> ConfiguratorThickness And _ vName <> ConfiguratorMaterial And _ vName <> ConfiguratorFlatFeat Then frmControlPanel.Controls("cboPos" & (p)) = strValue End If Next p Next vName End If vConfigNamesArray = ModelDoc.GetConfigurationNames For Each vConfigName In vConfigNamesArray If vConfigName = Config Then Set swCustPropMgr = ModelDoc.Extension.CustomPropertyManager(vConfigName) vCustPropNames = swCustPropMgr.GetNames If IsEmpty(vCustPropNames) = False Then For Each vName In vCustPropNames swCustPropMgr.Get3 vName, True, valOut, strValue For p = 1 To 8 If UCase(frmControlPanel.Controls("cboPos" & (p))) = UCase(vName) And _ vName <> ConfiguratorConfig And _ vName <> ConfiguratorPartName And _ vName <> ConfiguratorThickness And _ vName <> ConfiguratorMaterial And _ vName <> ConfiguratorFlatFeat Then frmControlPanel.Controls("cboPos" & (p)) = strValue End If Next p Next vName End If End If 'Exit For Next vConfigName If Err.Number > 0 Then Debug.Print "GetSetCustomPropFileNames " & "Err #" & Err.Number & " " & Err.Description End If End Sub Function GetDxfMap(Optional FromInit As Boolean = False) On Error Resume Next Dim f As Long Dim i As Long Dim CurMaps As String Dim CurIndex As Integer Dim FirstSlash As Integer Dim FileName As String Dim FolderName As String Dim MapsCount As Integer Dim FileNameExists As Boolean 'on startup of SW, map file index if -1 if none found, or 0 if one found. 'if one found, then dxfmappingfiles is on full path length. 'more files added during the session will lengthen dxfmapping files string with carriage return. 'each new found path represents a new index number. If FromInit = True Then origDxfMappingFileIndex = swApp.GetUserPreferenceIntegerValue(swDxfMappingFileIndex) frmMappingSettings.lblDxfMappingFileIndex = origDxfMappingFileIndex CurIndex = origDxfMappingFileIndex origDxfMappingFiles = swApp.GetUserPreferenceStringListValue(swDxfMappingFiles) frmMappingSettings.lblActiveMap = origDxfMappingFiles CurMaps = origDxfMappingFiles Debug.Print CurMaps origDxfMapping = swApp.GetUserPreferenceToggle(swDxfMapping) frmControlPanel.optMappingFile = origDxfMapping origDxfDontShowMap = swApp.GetUserPreferenceToggle(swDXFDontShowMap) frmMappingSettings.optDxfDontShowMap = origDxfDontShowMap origDxfVersion = swApp.GetUserPreferenceIntegerValue(swDxfVersion) frmMappingSettings.lblDxfVersion = origDxfVersion origDxfOutputFonts = swApp.GetUserPreferenceIntegerValue(swDxfOutputFonts) frmMappingSettings.lblDxfOutputFonts = origDxfOutputFonts origDxfOutputLineStyles = swApp.GetUserPreferenceIntegerValue(swDxfOutputLineStyles) frmMappingSettings.lblDxfOutputLineStyles = origDxfOutputLineStyles origDxfEndPointMerge = swApp.GetUserPreferenceToggle(swDxfEndPointMerge) frmMappingSettings.optDxfEndPointMerge = origDxfEndPointMerge origDxfMergingDistance = swApp.GetUserPreferenceDoubleValue(swDxfMergingDistance) frmMappingSettings.txtDxfMergingDistance = origDxfMergingDistance origDxfHighQualityExport = swApp.GetUserPreferenceToggle(swDXFHighQualityExport) frmMappingSettings.optDxfHighQualityExport = origDxfHighQualityExport origDxfExportSplinesAsSplines = swApp.GetUserPreferenceToggle(swDxfExportSplinesAsSplines) frmMappingSettings.optDxdExportSplinesAsSplines = origDxfExportSplinesAsSplines Else CurIndex = swApp.GetUserPreferenceIntegerValue(swDxfMappingFileIndex) frmMappingSettings.lblDxfMappingFileIndex = CurIndex CurMaps = swApp.GetUserPreferenceStringListValue(swDxfMappingFiles) Debug.Print CurMaps 'Will set the active map label below frmControlPanel.optMappingFile = swApp.GetUserPreferenceToggle(swDxfMapping) frmMappingSettings.optDxfDontShowMap = swApp.GetUserPreferenceToggle(swDXFDontShowMap) frmMappingSettings.optDxfEndPointMerge = swApp.GetUserPreferenceToggle(swDxfEndPointMerge) frmMappingSettings.txtDxfMergingDistance = swApp.GetUserPreferenceDoubleValue(swDxfMergingDistance) frmMappingSettings.optDxfHighQualityExport = swApp.GetUserPreferenceToggle(swDXFHighQualityExport) frmMappingSettings.optDxdExportSplinesAsSplines = swApp.GetUserPreferenceToggle(swDxfExportSplinesAsSplines) origDxfVersion = swApp.GetUserPreferenceIntegerValue(swDxfVersion) frmMappingSettings.lblDxfVersion = origDxfVersion origDxfOutputFonts = swApp.GetUserPreferenceIntegerValue(swDxfOutputFonts) frmMappingSettings.lblDxfOutputFonts = origDxfOutputFonts origDxfOutputLineStyles = swApp.GetUserPreferenceIntegerValue(swDxfOutputLineStyles) frmMappingSettings.lblDxfOutputLineStyles = origDxfOutputLineStyles End If 'add found maps to MapFiles string array and MappingSettings cbo If CurMaps = "" Then ReDim MapFiles(1) MapFiles(0) = "" CurIndex = 0 Else MapFiles = Split(CurMaps, vbLf, -1, vbTextCompare) End If For f = 0 To UBound(MapFiles) MapFiles(f) = Replace(MapFiles(f), vbLf, "", 1, -1, vbTextCompare) If Len(MapFiles(f)) > 4 And UCase(Right(MapFiles(f), 4)) = ".TXT" Then MapFiles(MapsCount) = MapFiles(f) Debug.Print "Map(" & MapsCount & ")--------------------" Debug.Print "Current index: " & CurIndex Debug.Print "Map full path: " & MapFiles(MapsCount) If MapsCount = CurIndex Then frmMappingSettings.lblActiveMap = MapFiles(CurIndex) frmMappingSettings.Repaint End If MapsCount = MapsCount + 1 End If Next f If frmMappingSettings.lblActiveMap = MapFiles(CurIndex) Then MappingFileLocation = FolderName & FileName frmControlPanel.frmMapFile.BorderColor = vbBlue frmControlPanel.frmMapFile.ForeColor = vbBlue frmControlPanel.frmMapFile.Caption = "Use Map File - Map Found" Else frmControlPanel.frmMapFile.BorderColor = vbRed frmControlPanel.frmMapFile.ForeColor = vbRed frmControlPanel.frmMapFile.Caption = "Use Map File - Not Found!" End If If Err.Number > 0 Then Debug.Print "GetDxfMap " & "Err #" & Err.Number & " " & Err.Description End If End Function Function SetDxfMap(MapFilePath As String, MapIndex As Integer) On Error Resume Next Dim Index As Integer Dim FirstSlash As Integer Dim FileName As String Dim FolderName As String swApp.SetUserPreferenceIntegerValue swDxfMappingFileIndex, MapIndex frmMappingSettings.lblDxfMappingFileIndex = MapIndex swApp.SetUserPreferenceStringListValue swDxfMappingFiles, MapFilePath swApp.SetUserPreferenceToggle swDxfMapping, frmControlPanel.optMappingFile swApp.SetUserPreferenceToggle swDXFDontShowMap, frmMappingSettings.optDxfDontShowMap swApp.SetUserPreferenceIntegerValue swDxfVersion, origDxfVersion swApp.SetUserPreferenceIntegerValue swDxfOutputFonts, origDxfOutputFonts swApp.SetUserPreferenceIntegerValue swDxfOutputLineStyles, origDxfOutputLineStyles swApp.SetUserPreferenceStringListValue swDxfEndPointMerge, frmMappingSettings.optDxfEndPointMerge swApp.SetUserPreferenceStringListValue swDxfMergingDistance, frmMappingSettings.txtDxfMergingDistance swApp.SetUserPreferenceStringListValue swDXFHighQualityExport, frmMappingSettings.optDxfHighQualityExport swApp.SetUserPreferenceStringListValue swDxfExportSplinesAsSplines, frmMappingSettings.optDxdExportSplinesAsSplines If Err.Number > 0 Then Debug.Print "SetDxfMap " & "Err #" & Err.Number & " " & Err.Description End If End Function Function ResetDxfMap() On Error Resume Next swApp.SetUserPreferenceToggle swDxfMapping, origDxfMapping swApp.SetUserPreferenceToggle swDXFDontShowMap, origDxfDontShowMap swApp.SetUserPreferenceIntegerValue swDxfVersion, origDxfVersion swApp.SetUserPreferenceIntegerValue swDxfOutputFonts, origDxfOutputFonts swApp.SetUserPreferenceIntegerValue swDxfMappingFileIndex, origDxfMappingFileIndex swApp.SetUserPreferenceIntegerValue swDxfOutputLineStyles, origDxfOutputLineStyles swApp.SetUserPreferenceStringListValue swDxfMappingFiles, origDxfMappingFiles swApp.SetUserPreferenceToggle swDxfEndPointMerge, origDxfEndPointMerge swApp.SetUserPreferenceDoubleValue swDxfMergingDistance, origDxfMergingDistance swApp.SetUserPreferenceToggle swDXFHighQualityExport, origDxfHighQualityExport swApp.SetUserPreferenceToggle swDxfExportSplinesAsSplines, origDxfExportSplinesAsSplines If Err.Number > 0 Then Debug.Print "ResetDxfMap " & "Err #" & Err.Number & " " & Err.Description End If End Function Function AddRemoveConfigSuffix(Action As Boolean, Optional Config As String = "") On Error Resume Next Dim ModifiedName As String Dim OriginalName As String Dim NewName As String Dim i As Long Dim swConfigArr As Variant Dim swConfig As SldWorks.Configuration Set swModel = swApp.ActiveDoc swConfigArr = swModel.GetConfigurationNames For i = 0 To UBound(swConfigArr) If Config = "" Then 'when Config is empty, all configs in file get the suffix appended GoTo Rename ElseIf Config = swConfigArr(i) Then GoTo Rename Else GoTo skip End If Rename: If Action = True Then OriginalName = swConfigArr(i) ModifiedName = Replace(swConfigArr(i), OriginalName, OriginalName & ConfigSuffix, 1, -1, vbTextCompare) NewName = ModifiedName Else ModifiedName = swConfigArr(i) OriginalName = Left(ModifiedName, Len(ModifiedName) - Len(ConfigSuffix)) NewName = OriginalName End If NewName = ReplaceChars(NewName) Set swConfig = swModel.GetConfigurationByName(swConfigArr(i)) swConfig.Name = NewName skip: Next i If Err.Number > 0 Then Debug.Print "AddRemoveConfigSuffix " & "Err #" & Err.Number & " " & Err.Description End If End Function Sub DeleteDesignTable() On Error Resume Next Dim swFeat As SldWorks.Feature Dim swSubFeat As SldWorks.Feature Set swFeat = swModel.FirstFeature While Not swFeat Is Nothing Debug.Print swFeat.GetTypeName Set swSubFeat = swFeat.GetFirstSubFeature While Not swSubFeat Is Nothing Debug.Print vbTab & swSubFeat.GetTypeName If swSubFeat.GetTypeName = "DesignTableFeature" Then swSubFeat.Select2 False, 0 swModel.EditDelete Exit Sub End If Set swSubFeat = swSubFeat.GetNextSubFeature Wend Set swFeat = swFeat.GetNextFeature Wend DeleteDesignTableHandler: If Err.Number > 0 Then MsgBox "DeleteDesignTable " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub DeleteRefPartConfigs() On Error Resume Next Dim Errors As Long Dim ExportPart As SldWorks.IModelDoc2 Dim Save As Boolean Dim i As Long Dim c As Long Dim f As Long Dim x As Long Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc Dim HasSmFlat As Integer Dim RefConfigs As Variant Dim RemainingConfigs As Variant Dim swCfg As Configuration Dim DoNotDelConfig As Boolean Dim RefConfig As SldWorks.Configuration Dim RConfig As String Dim ActiveCfgMrg As SldWorks.ConfigurationManager Dim ActiveCfg As SldWorks.Configuration Dim RemainingCount As Integer Set RefConfigs = swApp.ActiveDoc Set ActiveCfgMrg = swModel.ConfigurationManager RefConfigs = swModel.GetConfigurationNames RemainingConfigs = swModel.GetConfigurationNames RemainingCount = swModel.GetConfigurationCount - 1 For i = 0 To UBound(RefConfigs) RConfig = RefConfigs(i) For c = 0 To UBound(ExportConfigsArr) If Not IsEmpty(ExportConfigsArr) Then If UCase(Left(RConfig, Len(RConfig) - Len(ConfigSuffix))) = ExportConfigsArr(c) Then DoNotDelConfig = True End If End If Next c 'false = delete config If DoNotDelConfig = False Then Set swCfg = swModel.GetConfigurationByName(RefConfigs(i)) Set ActiveCfg = ActiveCfgMrg.ActiveConfiguration If ActiveCfg.Name = RefConfigs(i) Then If i = 0 Then swModel.ShowConfiguration RemainingConfigs(1) Else swModel.ShowConfiguration RemainingConfigs(0) End If End If swModel.DeleteConfiguration2 (RefConfigs(i)) RemainingConfigs = swModel.GetConfigurationNames Else DoNotDelConfig = False End If If InStr(1, RefConfigs(i), "SM-FLAT-PATTERN", vbTextCompare) <> 0 Or _ InStr(1, RefConfigs(i), "FLAT-PATTERN", vbTextCompare) <> 0 Then Set swCfg = swModel.GetConfigurationByName(RefConfigs(i)) Set ActiveCfg = ActiveCfgMrg.ActiveConfiguration If ActiveCfg.Name = RefConfigs(i) Then If i = 0 Then swModel.ShowConfiguration RemainingConfigs(1) Else swModel.ShowConfiguration RemainingConfigs(0) End If End If Set swCfg = swModel.GetConfigurationByName(RefConfigs(i)) swModel.DeleteConfiguration2 (RefConfigs(i)) End If Next i Save = swModel.Save3(swSaveAsOptions_Silent, 1, 1) If Err.Number > 0 Then Debug.Print "DeleteRefPartConfigs " & "Err #" & Err.Number & " " & Err.Description End If End Sub Sub FindReplaceCharactersInConfig() On Error Resume Next Dim ConfigName As String Dim TempName As String Dim i As Long Dim r As Long Dim vRet As Variant Dim swCfg As Configuration vRet = swModel.GetConfigurationNames For i = 0 To UBound(vRet) ConfigName = vRet(i) TempName = ReplaceChars(ConfigName) If TempName <> vRet(i) Then Set swCfg = swModel.GetConfigurationByName(vRet(i)) swCfg.Name = TempName End If Next i If Err.Number > 0 Then Debug.Print "FindReplaceCharacterInConfig " & "Err #" & Err.Number & " " & Err.Description End If End Sub Function ReplaceChars(TempName As String) As String On Error Resume Next Dim iChars As Variant Dim i As Long Dim r As Long iChars = Array("<", ">", ":", "/", """", "\", "|", "?", "*", "@") For r = 0 To UBound(iChars) TempName = Replace(TempName, iChars(r), "_", 1, -1, vbTextCompare) Next r ReplaceChars = TempName If Err.Number > 0 Then Debug.Print "ReplaceChars " & "Err #" & Err.Number & " " & Err.Description End If End Function Sub CorrectBendSuppression(ConfigObj As SldWorks.Configuration, IsSmFlatConfig As Boolean, FlatFeatName As String) On Error Resume Next Debug.Print ConfigObj.Name If IsSmFlatConfig = False Then UnsuppressFlatBends False, FlatFeatName SuppressFlatFeatures FlatFeatName Else UnsuppressFlatBends True, FlatFeatName UnsuppressFlatFeature FlatFeatName End If If Err.Number > 0 Then Debug.Print "CorrectBendSuppression " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub UnsuppressFlatBends(IsSmFlatConfig As Boolean, FlatFeatName As String) On Error Resume Next Dim swConfiMgr As SldWorks.ConfigurationManager Dim swConfig As SldWorks.Configuration Dim swFeat As SldWorks.Feature Dim swSubFeat As SldWorks.Feature Dim vSubFeat As Variant Dim lerrors As Long Dim lWarnings As Long Dim swSelMgr As SldWorks.SelectionMgr Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc Set swConfiMgr = swModel.ConfigurationManager Set swConfig = swConfiMgr.ActiveConfiguration Set swSelMgr = swModel.SelectionManager Set swFeat = swModel.FirstFeature Do Until swFeat Is Nothing If swFeat.Name = FlatFeatName Then Debug.Print "Feature Name : " & swFeat.Name Set swSubFeat = swFeat.GetFirstSubFeature Do Until swSubFeat Is Nothing If swSubFeat.GetTypeName = "ProfileFeature" Or swSubFeat.GetTypeName = "UiBend" Then Debug.Print "Flat Sub Feature: " & swSubFeat.Name If swSubFeat.SetSuppression2(swUnSuppressFeature, swThisConfiguration, Nothing) = False Then Debug.Print "Failed to unsuppress feature: " & swFeat.Name End If End If Set swSubFeat = swSubFeat.GetNextSubFeature Loop End If NextFeature: Set swFeat = swFeat.GetNextFeature Loop If Err.Number > 0 Then Debug.Print "UnsuppressFlatBends " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub SuppressFlatFeatures(FlatFeatName As String) On Error Resume Next Dim swConfiMgr As SldWorks.ConfigurationManager Dim swConfig As SldWorks.Configuration Dim swFeat As SldWorks.Feature Dim swSubFeat As SldWorks.Feature Dim vSubFeat As Variant Dim lerrors As Long Dim lWarnings As Long Dim swSelMgr As SldWorks.SelectionMgr Set swConfiMgr = swModel.ConfigurationManager Set swConfig = swConfiMgr.ActiveConfiguration Set swFeat = swModel.FirstFeature Do Until swFeat Is Nothing If swFeat.Name = FlatFeatName Then Debug.Print swFeat.Name If swFeat.SetSuppression2(swSuppressFeature, swThisConfiguration, Nothing) = False Then Debug.Print "Failed to suppress flat feature " & swFeat.Name End If End If Set swFeat = swFeat.GetNextFeature Loop If Err.Number > 0 Then Debug.Print "SuppressFlatFeatures " & "Err #" & Err.Number & " " & Err.Description End If End Sub Private Sub UnsuppressFlatFeature(FlatFeatName As String) On Error Resume Next Dim swConfiMgr As SldWorks.ConfigurationManager Dim swConfig As SldWorks.Configuration Dim swFeat As SldWorks.Feature Dim swSubFeat As SldWorks.Feature Dim vSubFeat As Variant Dim lerrors As Long Dim lWarnings As Long Dim swSelMgr As SldWorks.SelectionMgr Set swConfiMgr = swModel.ConfigurationManager Set swConfig = swConfiMgr.ActiveConfiguration Set swFeat = swModel.FirstFeature Do Until swFeat Is Nothing If swFeat.Name = FlatFeatName Then Debug.Print swFeat.Name If swFeat.SetSuppression2(swUnSuppressFeature, swThisConfiguration, Nothing) = False Then Debug.Print "Failed to Unsuppress flat feature" & swFeat.Name End If End If SkipFlatPattern: Set swFeat = swFeat.GetNextFeature Loop If Err.Number > 0 Then Debug.Print "UnsuppressFlatFeature " & "Err #" & Err.Number & " " & Err.Description End If End Sub Function BrowseForFile() Dim wso Dim hta Set wso = CreateObject("Wscript.Shell") hta = """about:" & vbCrLf _ & """" BrowseForFile = wso.Exec("mshta.exe " & hta).StdOut.ReadLine End Function Function BrowseForFolder(title, options, startPath) Dim shell Dim item Set shell = CreateObject("Shell.Application") Set item = shell.BrowseForFolder(0, title, options, startPath) 'If Cancel or Close is clicked, or no selection is made then the result is Nothing If item Is Nothing Then BrowseForFolder = "" Else AltSaveLocation = item.Items().item.Path & "\" If AltSaveLocation = OriginalFolderPath Then MsgBox "Folder Conflict!" & _ vbNewLine & vbNewLine & _ "Same as currently active doc location. Not allowed.", _ vbCritical + vbOKOnly, "Save Location not allowed!" AltSaveLocation = "" Else frmControlPanel.lblSaveLocation = AltSaveLocation Debug.Print "Atlernate Save location: " & AltSaveLocation End If End If End Function Sub Refresh() OriginalFolderPath = Strings.Left(swModel.GetPathName, Strings.Len(swModel.GetPathName) - Strings.Len(swModel.GetTitle)) 'has end-slash frmControlPanel.LblOriginalLocation = OriginalFolderPath mMain.GetDxfMap True End Sub Sub Main() On Error Resume Next Dim DocNames As Variant Dim FileObj As SldWorks.ModelDoc2 Dim DocName As String Dim i As Long Dim p As Long Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc If swApp.GetDocumentCount < 1 Then MsgBox "A file must be open to initialize the export!", _ vbOKOnly + vbCritical, _ "No File Open" End ElseIf swApp.GetDocumentCount > 1 Then If swModel.GetType = 1 Then If MsgBox("More than one Solidworks file is currently open." & _ vbNewLine & vbNewLine & _ "The DXF Export tool must close all non-active files " & _ "before proceeding. Click 'Yes' to close all non-active " & _ "files WITHOUT saving." & _ vbNewLine & vbNewLine & _ "Continue?", _ vbCritical + vbYesNo, _ "More than 1 document open") _ = vbNo Then Exit Sub End If End If If swModel.GetType = 2 Then If MsgBox("The DXF Export Tool has detected an assembly for export. " & _ "The tool cannot detect whether additional Solidworks files " & _ "are open. Please confirm that no additional Solidworks files are open." & _ vbNewLine & vbNewLine & _ "If 'Yes' is selected, the DXF Export tool will close " & _ "all non-active files WITHOUT saving." & _ vbNewLine & vbNewLine & _ "Select 'No' if you have additional Solidworks files open " & _ "that require saving." & _ vbNewLine & vbNewLine & _ "Continue?", _ vbQuestion + vbYesNo, _ "Active doc check") _ = vbNo Then End End If End If 'Close non relevant docs that are open in SW DocNames = swApp.GetDocuments For i = 0 To UBound(DocNames) Set FileObj = DocNames(i) If FileObj.GetTitle <> swModel.GetTitle Then swApp.CloseDoc (FileObj.GetTitle) End If Next i End If OriginalFolderPath = Strings.Left(swModel.GetPathName, Strings.Len(swModel.GetPathName) - Strings.Len(swModel.GetTitle)) 'has end-slash OriginalPathName = swModel.GetPathName frmControlPanel.LblOriginalLocation = OriginalFolderPath 'form init settings If swModel.GetType = 1 Then frmControlPanel.optAssembly.Enabled = False ElseIf swModel.GetType = 2 Then frmControlPanel.optBatch.Enabled = False frmControlPanel.optSingle.Enabled = False frmControlPanel.optAssembly = True frmControlPanel.chkSelectAll.Enabled = False frmControlPanel.lblCurrentFile = OriginalPathName 'frmControlPanel.chkDeleteSmFlatConfigs.Enabled = False 'frmControlPanel.chkAddRefPart.Enabled = False Else MsgBox "Export tool must be initiated from a .sldprt " & _ "or .sldasm file only." & _ vbNewLine & vbNewLine & _ "Terminating...", _ vbExclamation + vbOKOnly, _ ".SLDPRT/.SLDASM not found" End End If mMain.UpdateStatus "Not Running", vbRed, "", "" frmControlPanel.optDXF.Value = True frmControlPanel.chkAddConfigSuffix = False frmControlPanel.cmdRunExport.Caption = "Run Export" frmControlPanel.listExportOptions.Locked = True frmControlPanel.listExportOptions.BackColor = RGB(240, 240, 240) frmControlPanel.txtViewScale = 100 For p = 1 To 8 With frmControlPanel.Controls("cboPos" & (p)) .AddItem ConfiguratorConfig .AddItem ConfiguratorPartName .AddItem ConfiguratorThickness .AddItem ConfiguratorMaterial .AddItem ConfiguratorFlatFeat End With Next p frmControlPanel.cboPos1 = ConfiguratorConfig frmControlPanel.cboPos2 = ConfiguratorMaterial frmControlPanel.cboPos3 = ConfiguratorThickness frmControlPanel.cboPos4 = "" frmControlPanel.cboPos5 = "" frmControlPanel.cboPos6 = "" frmControlPanel.cboPos7 = "" frmControlPanel.cboPos8 = "" mMain.GetDxfMap True frmControlPanel.Show If Err.Number > 0 Then Debug.Print "Main" & "Err #" & Err.Number & " " & Err.Description End If End Sub