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