Title describes all the problem that I have, I take this macro from the CodeStack I think, and then rewrite it in some moments, don remember where exactly because it was long ago.
Macro make DXF files of flat pattern sheet-metal Part or Assembly Components.
I highlight parts of code where I think there can be problem, but don't take this too seriously, I'm new to macro and API.
Enum SheetMetalOptions_e ExportFlatPatternGeometry = 1 IncludeHiddenEdges = 2 ExportBendLines = 4 IncludeSketches = 8 MergeCoplanarFaces = 16 ExportLibraryFeatures = 32 ExportFormingTools = 64 ExportBoundingBox = 2048 End Enum Const SKIP_EXISTING_FILES As Boolean = False Const OPEN_APP_PATH As String = "" Const OUT_NAME_TEMPLATE As String = "DXFs\<_FileName_>, t=<\$PRP:Толщина_листа>, <\$PRP:Материал>, <\$PRP:Количество>шт.dxf" Const FLAT_PATTERN_OPTIONS As Integer = SheetMetalOptions_e.ExportBendLines + SheetMetalOptions_e.ExportFlatPatternGeometry Dim swApp As SldWorks.SldWorks Sub main() Set swApp = Application.SldWorks try_: On Error GoTo catch_ Dim swModel As SldWorks.ModelDoc2 Set swModel = swApp.ActiveDoc If swModel Is Nothing Then Err.Raise vbError, "", "Откройте документ сборки или детали." End If If swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Then Dim swAssy As SldWorks.AssemblyDoc Set swAssy = swModel swAssy.ResolveAllLightWeightComponents True Dim vComps As Variant vComps = GetDistinctSheetMetalComponents(swAssy) Dim i As Integer For i = 0 To UBound(vComps) Dim swComp As SldWorks.Component2 Set swComp = vComps(i) ProcessSheetMetalModel swAssy, swComp.GetModelDoc2(), swComp.ReferencedConfiguration Next ElseIf swModel.GetType() = swDocumentTypes_e.swDocPART Then Dim swPart As SldWorks.PartDoc Set swPart = swApp.ActiveDoc ProcessSheetMetalModel swPart, swPart, swPart.ConfigurationManager.ActiveConfiguration.Name Else Err.Raise vbError, "", "Допускаются только документы сборки или детали" End If swApp.SendMsgToUser2 "Файлы конвенртированны в DXF", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk GoTo finally_ catch_: swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk finally_: End Sub Function GetDistinctSheetMetalComponents(assy As SldWorks.AssemblyDoc) As Variant Dim vComps As Variant vComps = assy.GetComponents(False) Dim i As Integer Dim swSheetMetalComps() As SldWorks.Component2 For i = 0 To UBound(vComps) Dim swComp As SldWorks.Component2 Set swComp = vComps(i) If False = swComp.IsSuppressed() Then If Not ContainsComponent(swSheetMetalComps, swComp) Then If IsSheetMetalComponent(swComp) Then If (Not swSheetMetalComps) = -1 Then ReDim swSheetMetalComps(0) Else ReDim Preserve swSheetMetalComps(UBound(swSheetMetalComps) + 1) End If Set swSheetMetalComps(UBound(swSheetMetalComps)) = swComp End If End If End If Next If (Not swSheetMetalComps) = -1 Then GetDistinctSheetMetalComponents = Empty Else GetDistinctSheetMetalComponents = swSheetMetalComps End If End Function Function IsSheetMetalComponent(comp As SldWorks.Component2) As Boolean Dim vBodies As Variant vBodies = comp.GetBodies3(swBodyType_e.swSolidBody, Empty) If Not IsEmpty(vBodies) Then Dim i As Integer For i = 0 To UBound(vBodies) Dim swBody As SldWorks.Body2 Set swBody = vBodies(i) If False <> swBody.IsSheetMetal() Then IsSheetMetalComponent = True Exit Function End If Next End If IsSheetMetalComponent = False End Function Function ContainsComponent(comps As Variant, swComp As SldWorks.Component2) As Boolean Dim i As Integer For i = 0 To UBound(comps) Dim swThisComp As SldWorks.Component2 Set swThisComp = comps(i) If swThisComp.GetPathName() = swComp.GetPathName() And swThisComp.ReferencedConfiguration = swComp.ReferencedConfiguration Then ContainsComponent = True Exit Function End If Next ContainsComponent = False End Function Function ComposeOutFileName(template As String, rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String, flatPatternFeat As SldWorks.Feature, cutListFeat As SldWorks.Feature) As String Dim regEx As Object Set regEx = CreateObject("VBScript.RegExp") regEx.Global = True regEx.IgnoreCase = True regEx.Pattern = "<[^>]*>" Dim regExMatches As Object Set regExMatches = regEx.Execute(template) Dim i As Integer Dim outFileName As String outFileName = template For i = regExMatches.Count - 1 To 0 Step -1 Dim regExMatch As Object Set regExMatch = regExMatches.Item(i) Dim tokenName As String tokenName = Mid(regExMatch.Value, 2, Len(regExMatch.Value) - 2) outFileName = Left(outFileName, regExMatch.FirstIndex) & ResolveToken(tokenName, rootModel, sheetMetalModel, conf, flatPatternFeat, cutListFeat) & Right(outFileName, Len(outFileName) - (regExMatch.FirstIndex + regExMatch.Length)) Next ComposeOutFileName = ReplaceInvalidPathSymbols(GetFullPath(rootModel, outFileName)) End Function Function ReplaceInvalidPathSymbols(path As String) As String Const REPLACE_SYMB As String = "_" Dim res As String res = Right(path, Len(path) - Len("X:\")) Dim drive As String drive = Left(path, Len("X:\")) Dim invalidSymbols As Variant invalidSymbols = Array("/", ":", "*", "?", """", "<", ">", "|") Dim i As Integer For i = 0 To UBound(invalidSymbols) Dim invalidSymb As String invalidSymb = CStr(invalidSymbols(i)) res = Replace(res, invalidSymb, REPLACE_SYMB) Next ReplaceInvalidPathSymbols = drive + res End Function Function ResolveToken(token As String, rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String, flatPatternFeat As SldWorks.Feature, cutListFeat As SldWorks.Feature) As String Const FILE_NAME_TOKEN As String = "_FileName_" Const ASSM_FILE_NAME_TOKEN As String = "_AssmFileName_" Const FEAT_NAME_TOKEN As String = "_FeatureName_" Const CONF_NAME_TOKEN As String = "_ConfName_" Const PRP_TOKEN As String = "\$PRP:" Const CUT_LIST_PRP_TOKEN As String = "\$CLPRP:" Const ASM_PRP_TOKEN As String = "\$ASSMPRP:" Select Case LCase(token) Case LCase(FILE_NAME_TOKEN) ResolveToken = GetFileNameWithoutExtension(sheetMetalModel.GetPathName) Case LCase(FEAT_NAME_TOKEN) ResolveToken = flatPatternFeat.Name Case LCase(CONF_NAME_TOKEN) ResolveToken = conf Case LCase(ASSM_FILE_NAME_TOKEN) If rootModel.GetPathName() = "" Then Err.Raise vbError, "", "Сборка должна быть сохранена" & ASSM_FILE_NAME_TOKEN End If ResolveToken = GetFileNameWithoutExtension(rootModel.GetPathName()) Case Else Dim prpName As String If Left(token, Len(PRP_TOKEN)) = PRP_TOKEN Then prpName = Right(token, Len(token) - Len(PRP_TOKEN)) ResolveToken = GetModelPropertyValue(sheetMetalModel, conf, prpName) ElseIf Left(token, Len(ASM_PRP_TOKEN)) = ASM_PRP_TOKEN Then prpName = Right(token, Len(token) - Len(ASM_PRP_TOKEN)) ResolveToken = GetModelPropertyValue(rootModel, rootModel.ConfigurationManager.ActiveConfiguration.Name, prpName) ElseIf Left(token, Len(CUT_LIST_PRP_TOKEN)) = CUT_LIST_PRP_TOKEN Then prpName = Right(token, Len(token) - Len(CUT_LIST_PRP_TOKEN)) ResolveToken = GetPropertyValue(cutListFeat.CustomPropertyManager, prpName) Else Err.Raise vbError, "", "Unrecognized token: " & token End If End Select End Function Function GetModelPropertyValue(model As SldWorks.ModelDoc2, confName As String, prpName As String) As String Dim prpVal As String Dim swCustPrpMgr As SldWorks.CustomPropertyManager Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName) prpVal = GetPropertyValue(swCustPrpMgr, prpName) If prpVal = "" Then Set swCustPrpMgr = model.Extension.CustomPropertyManager("") prpVal = GetPropertyValue(swCustPrpMgr, prpName) End If GetModelPropertyValue = prpVal End Function Function GetPropertyValue(custPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String Dim resVal As String custPrpMgr.Get2 prpName, "", resVal GetPropertyValue = resVal End Function Function GetFileNameWithoutExtension(path As String) As String GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1) End Function Function GetCutListFeatures(model As SldWorks.ModelDoc2) As Variant GetCutListFeatures = GetFeaturesByType(model, "CutListFolder") End Function Function GetFlatPatternFeatures(model As SldWorks.ModelDoc2) As Variant GetFlatPatternFeatures = GetFeaturesByType(model, "FlatPattern") End Function Sub ProcessSheetMetalModel(rootModel As SldWorks.ModelDoc2, sheetMetalModel As SldWorks.ModelDoc2, conf As String) Dim vCutListFeats As Variant vCutListFeats = GetCutListFeatures(sheetMetalModel) If Not IsEmpty(vCutListFeats) Then Dim vFlatPatternFeats As Variant vFlatPatternFeats = GetFlatPatternFeatures(sheetMetalModel) If Not IsEmpty(vFlatPatternFeats) Then Dim swProcessedCutListsFeats() As SldWorks.Feature Dim i As Integer For i = 0 To UBound(vFlatPatternFeats) Dim swFlatPatternFeat As SldWorks.Feature Dim swFlatPattern As SldWorks.FlatPatternFeatureData Set swFlatPatternFeat = vFlatPatternFeats(i) Set swFlatPattern = swFlatPatternFeat.GetDefinition Dim swFixedEnt As SldWorks.Entity Set swFixedEnt = swFlatPattern.FixedFace2 Dim swBody As SldWorks.Body2 If TypeOf swFixedEnt Is SldWorks.Face2 Then Dim swFixedFace As SldWorks.Face2 Set swFixedFace = swFixedEnt Set swBody = swFixedFace.GetBody ElseIf TypeOf swFixedEnt Is SldWorks.Edge Then Dim swFixedEdge As SldWorks.Edge Set swFixedEdge = swFixedEnt Set swBody = swFixedEdge.GetBody ElseIf TypeOf swFixedEnt Is SldWorks.Vertex Then Dim swFixedVert As SldWorks.Vertex Set swFixedVert = swFixedEnt Set swBody = swFixedVert.GetBody End If Dim swCutListFeat As SldWorks.Feature Set swCutListFeat = FindCutListFeature(vCutListFeats, swBody) If Not swCutListFeat Is Nothing Then Dim isUnique As Boolean If (Not swProcessedCutListsFeats) = -1 Then isUnique = True ElseIf Not ContainsSwObject(swProcessedCutListsFeats, swCutListFeat) Then isUnique = True Else isUnique = False End If If isUnique Then If (Not swProcessedCutListsFeats) = -1 Then ReDim swProcessedCutListsFeats(0) Else ReDim Preserve swProcessedCutListsFeats(UBound(swProcessedCutListsFeats) + 1) End If Set swProcessedCutListsFeats(UBound(swProcessedCutListsFeats)) = swCutListFeat Dim outFileName As String outFileName = ComposeOutFileName(OUT_NAME_TEMPLATE, rootModel, sheetMetalModel, conf, swFlatPatternFeat, swCutListFeat) If Not SKIP_EXISTING_FILES Or Not FileExists(outFileName) Then ExportFlatPattern sheetMetalModel, swFlatPatternFeat, outFileName, FLAT_PATTERN_OPTIONS, conf If OPEN_APP_PATH <> "" Then OpenFile outFileName End If End If End If Else Err.Raise vbError, "", "Failed to find cut-list for flat pattern " & swFlatPatternFeat.Name End If Next Else Err.Raise vbError, "", "No flat pattern features found" End If Else Err.Raise vbError, "", "No cut-list items found" End If End Sub Function FileExists(filePath As String) As Boolean FileExists = Dir(filePath) <> "" End Function Function FindCutListFeature(vCutListFeats As Variant, body As SldWorks.Body2) As SldWorks.Feature Dim i As Integer For i = 0 To UBound(vCutListFeats) Dim swCutListFeat As SldWorks.Feature Set swCutListFeat = vCutListFeats(i) Dim swBodyFolder As SldWorks.BodyFolder Set swBodyFolder = swCutListFeat.GetSpecificFeature2 Dim vBodies As Variant vBodies = swBodyFolder.GetBodies If ContainsSwObject(vBodies, body) Then Set FindCutListFeature = swCutListFeat End If Next End Function Function ContainsSwObject(vArr As Variant, obj As Object) As Boolean If Not IsEmpty(vArr) Then Dim i As Integer For i = 0 To UBound(vArr) Dim swObj As Object Set swObj = vArr(i) If swApp.IsSame(swObj, obj) = swObjectEquality.swObjectSame Then ContainsSwObject = True Exit Function End If Next End If ContainsSwObject = False End Function Function GetFeaturesByType(model As SldWorks.ModelDoc2, typeName As String) As Variant Dim swFeats() As SldWorks.Feature Dim swFeat As SldWorks.Feature Set swFeat = model.FirstFeature Do While Not swFeat Is Nothing If typeName = "CutListFolder" And swFeat.GetTypeName2() = "SolidBodyFolder" Then Dim swBodyFolder As SldWorks.BodyFolder Set swBodyFolder = swFeat.GetSpecificFeature2 swBodyFolder.UpdateCutList End If ProcessFeature swFeat, swFeats, typeName Set swFeat = swFeat.GetNextFeature Loop If (Not swFeats) = -1 Then GetFeaturesByType = Empty Else GetFeaturesByType = swFeats End If End Function Sub ProcessFeature(thisFeat As SldWorks.Feature, featsArr() As SldWorks.Feature, typeName As String) If thisFeat.GetTypeName2() = typeName Then If (Not featsArr) = -1 Then ReDim featsArr(0) Set featsArr(0) = thisFeat Else Dim i As Integer For i = 0 To UBound(featsArr) If swApp.IsSame(featsArr(i), thisFeat) = swObjectEquality.swObjectSame Then Exit Sub End If Next ReDim Preserve featsArr(UBound(featsArr) + 1) Set featsArr(UBound(featsArr)) = thisFeat End If End If Dim swSubFeat As SldWorks.Feature Set swSubFeat = thisFeat.GetFirstSubFeature While Not swSubFeat Is Nothing ProcessFeature swSubFeat, featsArr, typeName Set swSubFeat = swSubFeat.GetNextSubFeature Wend End Sub Sub ExportFlatPattern(part As SldWorks.PartDoc, flatPattern As SldWorks.Feature, outFilePath As String, opts As SheetMetalOptions_e, conf As String) Dim swModel As SldWorks.ModelDoc2 Set swModel = part Dim error As ErrObject Dim hide As Boolean try_: On Error GoTo catch_ If False = swModel.Visible Then hide = True swModel.Visible = True End If swApp.ActivateDoc3 swModel.GetPathName(), False, swRebuildOnActivation_e.swDontRebuildActiveDoc, 0 swModel.FeatureManager.EnableFeatureTree = False swModel.FeatureManager.EnableFeatureTreeWindow = False swModel.ActiveView.EnableGraphicsUpdate = False Dim curConf As String curConf = swModel.ConfigurationManager.ActiveConfiguration.Name If curConf <> conf Then If False = swModel.ShowConfiguration2(conf) Then Err.Raise vbError, "", "Failed to activate configuration" End If End If Dim outDir As String outDir = Left(outFilePath, InStrRev(outFilePath, "\")) CreateDirectories outDir Dim modelPath As String modelPath = part.GetPathName If modelPath = "" Then Err.Raise vbError, "", "Part document must be saved" End If If False <> flatPattern.Select2(False, -1) Then If False = part.ExportToDWG2(outFilePath, modelPath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Empty, False, False, 13, Empty) Then Err.Raise vbError, "", "Failed to export flat pattern" End If Else Err.Raise vbError, "", "Failed to select flat-pattern" End If swModel.ShowConfiguration2 curConf GoTo finally_ catch_: Set error = Err finally_: swModel.FeatureManager.EnableFeatureTree = True swModel.FeatureManager.EnableFeatureTreeWindow = True swModel.ActiveView.EnableGraphicsUpdate = True If hide Then swApp.CloseDoc swModel.GetTitle End If If Not error Is Nothing Then Err.Raise error.Number, error.Source, error.Description, error.HelpFile, error.HelpContext End If End Sub Sub OpenFile(filePath As String) If OPEN_APP_PATH = "*" Then Shell """" & filePath & """" Else Shell """" & OPEN_APP_PATH & """" & " " & """" & filePath & """" End If End Sub Sub CreateDirectories(path As String) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(path) Then Exit Sub End If CreateDirectories fso.GetParentFolderName(path) fso.CreateFolder path End Sub Function GetFullPath(model As SldWorks.ModelDoc2, path As String) GetFullPath = path If IsPathRelative(path) Then If Left(path, 1) <> "\" Then path = "\" & path End If Dim modelPath As String Dim modelDir As String modelPath = model.GetPathName modelDir = Left(modelPath, InStrRev(modelPath, "\") - 1) GetFullPath = modelDir & path End If End Function Function IsPathRelative(path As String) IsPathRelative = Mid(path, 2, 1) <> ":" And Not IsPathUnc(path) End Function Function IsPathUnc(path As String) IsPathUnc = Left(path, 2) = "\\" End Function