Макрос сохранения развертки в DWG

[Вадим Митрофанович 3]

Export Part to DWG Example (VBA) Mod by Kyr95 & Snake-60---!!!!!!!!!!!!!!!!!!

Попробовал макрос и на гибку и на просто лист. Всё (наконец) работает. И сигнализирует, что макрос отработал. И не выдает пунктирные линии сгибов на ДХФ, что важно! Макрос универсал! Автору респект и уважуха.

[mrNicetone 3]

23.04.2021 в 20:43, Snake 60 сказал:

Идея хорошая... будет свободное время - попробую реализовать...

Добрый день. Ещё раз спасибо за макрос. Пользуюсь на постоянной основе.

Мегаполезной оказалась галка "отразить зеркально" ( когда материал - нержавейка с пленкой, а SW не понятно как развернёт деталь ).

Также плюс, что возможно сохранять несколько файлов из нескольких окон SW одновременно ( конфигураций у меня бывает более 300 в разных файлах ).

 

Возникли такие вопросы:

1) Можно ли при возникновении ошибки останавливать работу макроса? ( чтоб не нажимать ОК для всех конфигураций )

2) Можно ли организовать работу макроса в "тихом" режиме? (я сворачиваю всё, но периодически выскакивает окно SW - мешает работе)

3) Чтобы работал "Набор свойств из вкладки конфигурации" нужно в шаблоне детали  создать свойства "Толщина" , "Количество" , "Материал" , "Обозначение"?

 

В предыдущем сообщении потерялась картинка, если когда- нибудь займётесь, то выпадающий список вроде бы был такой:
обозначение (имя файла до первого пробела) = АБВГ.12.34.00
исполнение = -01
наименование (имя файла после первого пробела) = Пример 
толщина = 1,0
габариты = 110х2100
количество = 1
материал = Ст3
поле для ввода = ОЦ

имя DXF'а: АБВГ.12.34.00-01 Пример 1,0х110х2100мм 1шт Ст3 ОЦ

[OlgaKubrik 0]

Здравствуйте!

Очень нужная тема обсуждается на форуме, но за годы, что тема живет, она слегка изменилась?

Мой запрос в том, чтобы макрос сохранял dxf листового металла всех конфигураций детали. Такой макрос существует? Скачала макрос из сообщения Snake-60 от 25 апреля 2021 года и получается dxf одной, текущей, конфигурации детали. Может быть подскажете, что не так или что нужно было скачать?

Заранее спасибо!

Столько конфигураций и так часто они меняются, что вручную не гуманно сохранять, тону просто.

 

[Kometa_69 6]

1 час назад, OlgaKubrik сказал:

Здравствуйте!

Очень нужная тема обсуждается на форуме, но за годы, что тема живет, она слегка изменилась?

Мой запрос в том, чтобы макрос сохранял dxf листового металла всех конфигураций детали. Такой макрос существует? Скачала макрос из сообщения Snake-60 от 25 апреля 2021 года и получается dxf одной, текущей, конфигурации детали. Может быть подскажете, что не так или что нужно было скачать?

Заранее спасибо!

Столько конфигураций и так часто они меняются, что вручную не гуманно сохранять, тону просто.

 

Здравствуйте. Попробуйте вот этот вариант. Переделывала под себя, основываясь на другой. При работе макрос останавливается каждые 10 конфигураций и спрашивает продолжать ему или нет. Просто у меня детали имеют по 200-250 конфигураций, чтобы комп не завис предусмотрена такая функция. Я уже выкладывала другой вариант, но он был лично для меня неудобен.

ExportToDWG(c кнопкой Stop)_v2.1.swp

[OlgaKubrik 0]

1 час назад, Kometa_69 сказал:

Здравствуйте. Попробуйте вот этот вариант. Переделывала под себя, основываясь на другой. При работе макрос останавливается каждые 10 конфигураций и спрашивает продолжать ему или нет. Просто у меня детали имеют по 200-250 конфигураций, чтобы комп не завис предусмотрена такая функция. Я уже выкладывала другой вариант, но он был лично для меня неудобен.

ExportToDWG(c кнопкой Stop)_v2.1.swp 79 \u041a\u0431 · 3 скачивания

Спасибо!!!!!!!!!

Это именно то, что было нужно!!!!!!!

Попробую доделать под себя детали, может быть получится, я вообще не умею писать макросы 

[Livarh 0]

22.04.2021 в 21:30, Snake 60 сказал:

Да не мой это макрос... его выкладывал @mrNicetone я всего лишь его подкорректировал под Ваши хотелки.

Жаль, у меня Ваш макрос не работает(

[SWX 94]

1 hour ago, Livarh said:

макрос не работает(

если б написали версию своего солида и что такое "не работает" (ошибка вылетает или просто ничего не происходит), может, кто и подсказал что

[livedten 34]

Solidworks 2022 sp 0.0  - не отрабатывает ругается

Скрытый текст

[Sturmann 34]

15.09.2021 в 15:53, mrNicetone сказал:

Добрый день. Ещё раз спасибо за макрос. Пользуюсь на постоянной основе.

Мегаполезной оказалась галка "отразить зеркально" ( когда материал - нержавейка с пленкой, а SW не понятно как развернёт деталь ).

Также плюс, что возможно сохранять несколько файлов из нескольких окон SW одновременно ( конфигураций у меня бывает более 300 в разных файлах ).

 

Возникли такие вопросы:

1) Можно ли при возникновении ошибки останавливать работу макроса? ( чтоб не нажимать ОК для всех конфигураций )

2) Можно ли организовать работу макроса в "тихом" режиме? (я сворачиваю всё, но периодически выскакивает окно SW - мешает работе)

3) Чтобы работал "Набор свойств из вкладки конфигурации" нужно в шаблоне детали  создать свойства "Толщина" , "Количество" , "Материал" , "Обозначение"?

 

В предыдущем сообщении потерялась картинка, если когда- нибудь займётесь, то выпадающий список вроде бы был такой:
обозначение (имя файла до первого пробела) = АБВГ.12.34.00
исполнение = -01
наименование (имя файла после первого пробела) = Пример 
толщина = 1,0
габариты = 110х2100
количество = 1
материал = Ст3
поле для ввода = ОЦ

имя DXF'а: АБВГ.12.34.00-01 Пример 1,0х110х2100мм 1шт Ст3 ОЦ

Здравствуйте.

Не могли бы вы пояснить:

Как вы после создания dxf файлов замыкаете контура и переводите их все в полилинии? (Получается такой цикл: открыть файл-замкнуть контур- сохранить- закрыть файл. И так 300 раз?) Или у вас есть макрос на эту процедуру? Если есть тогда как проверить работу этого макроса (может он что то не замкнул)?

[Sturmann 34]

21 час назад, livedten сказал:

Solidworks 2022 sp 0.0  - не отрабатывает ругается

  Скрыть содержимое

ну тут только отлаживать остается.

хотя скорее всего он не может найти файл по пути в переменной.

или файна нет или путь неправильный или путь пустой

[Snake 60 757]

27.12.2021 в 14:23, livedten сказал:

Solidworks 2022 sp 0.0  - не отрабатывает ругается

@livedten  Рядом с макросом должен лежать одноименный TXT-файл. Судя по ошибке, макрос не может его открыть или получить доступ на запись, если это проблема с правами доступа.

15.11.2021 в 15:38, Livarh сказал:

Жаль, у меня Ваш макрос не работает(

Напишите подробней, что за ошибка, лучше со скринами, как сделал @livedten

[livedten 34]

30.12.2021 в 22:57, Snake 60 сказал:

@livedten  Рядом с макросом должен лежать одноименный TXT-файл. Судя по ошибке, макрос не может его открыть или получить доступ на запись, если это проблема с правами доступа.

Напишите подробней, что за ошибка, лучше со скринами, как сделал @livedten

Все верно не хватало его, после обновления оси исчез., спасибо за наводку.

[Sergej0895 0]

День добрый!

А есть ли возможность в данную строку:

Const OUT_NAME_TEMPLATE As String = "DXFs\<_FileName_>_<$CLPRP:Толщина листового металла>мм_шт.dxf"

в наименование dxf добавить информацию о гибке?

То есть, если есть гибка, то в конце наименования (перед расширением файла) дописать "кол-во" Гибов (если гибов "0", то есть просто плоская деталь, то оставить как есть).

Если не ошибаюсь, то это параметр $PRPWLD:"Bends", но с у меня к сожалению ничего не вышло.

[Sturmann 34]

2 часа назад, Sergej0895 сказал:

День добрый!

А есть ли возможность в данную строку:

Const OUT_NAME_TEMPLATE As String = "DXFs\<_FileName_>_<$CLPRP:Толщина листового металла>мм_шт.dxf"

в наименование dxf добавить информацию о гибке?

То есть, если есть гибка, то в конце наименования (перед расширением файла) дописать "кол-во" Гибов (если гибов "0", то есть просто плоская деталь, то оставить как есть).

Если не ошибаюсь, то это параметр $PRPWLD:"Bends", но с у меня к сожалению ничего не вышло.

Конечно можно. 

Только не увлекайтесь - количество символов в пути файла в вин ограничено. 

[Sergej0895 0]

В целом вроде все получилось, но как мне добавить условие, что если гибов "0", то пусть в имя не пишется значение "<$PRPWLD:Сгибы>" и слово "Гибов"? 

Попробовал через ввод новой переменной (добавить к ней условия значений "<$PRPWLD:Сгибы>") и прописать ее в наименование, но не получилось (вылетает ошибка).

В коде выделил строки, которые добавил в код.

 

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 OUT_NAME_TEMPLATE As String = "DXFs\<_FileName_>_<$CLPRP:Толщина листового металла>мм_шт_<$PRPWLD:Сгибы>Гибов.dxf"

Const FLAT_PATTERN_OPTIONS As Integer = 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, "", "Please open assembly or part document"
    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, "", "Only assembly and part documents are supported"
    End If
    
    swApp.SendMsgToUser2 "Operation completed", 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 BEND_COUNT_PRP_TOKEN As String = "$PRPWLD:"
    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 assy.GetPathName() = "" Then
                Err.Raise vbError, "", "Assembly must be saved to use " & ASSM_FILE_NAME_TOKEN
            End If
            ResolveToken = GetFileNameWithoutExtension(assy.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)
            ElseIf Left(token, Len(BEND_COUNT_PRP_TOKEN)) = BEND_COUNT_PRP_TOKEN Then
                prpName = Right(token, Len(token) - Len(BEND_COUNT_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
                        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, opts, 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 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
 

[mrNicetone 3]

27.12.2021 в 14:39, Sturmann сказал:

Здравствуйте.

Не могли бы вы пояснить:

Как вы после создания dxf файлов замыкаете контура и переводите их все в полилинии? (Получается такой цикл: открыть файл-замкнуть контур- сохранить- закрыть файл. И так 300 раз?) Или у вас есть макрос на эту процедуру? Если есть тогда как проверить работу этого макроса (может он что то не замкнул)?

Добрый день, я не преобразовываю в полилинии, контура замкнуты, иначе SW не выдавливает деталь. Для чего делать полилинии?

[Sturmann 34]

2 часа назад, mrNicetone сказал:

Добрый день, я не преобразовываю в полилинии, контура замкнуты, иначе SW не выдавливает деталь. Для чего делать полилинии?

не уверен что они замкнуты.

они все примитивами.

для чего переводить в полилинии:

- аппроксимация

- перевод сплайном

- замыкание контуров

[mrNicetone 3]

14 минут назад, Sturmann сказал:

не уверен что они замкнуты.

они все примитивами.

для чего переводить в полилинии:

- аппроксимация

- перевод сплайном

- замыкание контуров

контуры замкнуты, иначе лазер бы не вырезал
что примитивами?
мы о dxf'e говорим?

[Sturmann 34]

48 минут назад, mrNicetone сказал:

контуры замкнуты, иначе лазер бы не вырезал
что примитивами?
мы о dxf'e говорим?

да, о нем

лазер вырежет но с остановками (хотя какая УП там- могу ошибаться)

До объединения (дуга и два отрезка):

 

после:

[Анд 0]

Здравствуйте! Отличный макрос, очень помогает в работе.