Допилить макрос Что бы выгружал по папка - толщинам металл Так как идет вся солянка в сборе

[Operator 1945 0]

 

Private Sub UserForm_Activate()
    CheckBox1.Value = True
    CheckBox2.Value = False
End Sub

 

 

Private Sub CommandButton3_Click()
    Dim selectedFolder As String
    
    selectedFolder = BrowseForFolder(PathOfLocks)
    If (selectedFolder <> "") And (Left(selectedFolder, 1) <> ":") Then
        selectedFolder = Replace(selectedFolder, PathOfLocks, "")
    Else
        selectedFolder = ""
    End If
    Debug.Print Left(selectedFolder, 1)
    TextBox1.Text = selectedFolder
End Sub

 

 

Function BrowseForFolder(Optional OpenAt As Variant) As Variant             - возврощает полный путь до папки выбранный пользователем 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Выбрать папку :", 0, OpenAt)
    If (Not objFolder Is Nothing) Then
        Set objFolderItem = objFolder.Self
        BrowseForFolder = objFolderItem.path
    End If
    If PathOfDirectory = BrowseForFolder & "\" Then
        BrowseForFolder = ""
    End If
End Function

 

 

Private Sub CommandButton1_Click()
    
    Dim bRet                    As Boolean
    Dim path                    As String
    Dim filename                As String
    Dim i                       As Integer
    Dim nStart                  As Single
    Dim subdir_name             As String
    Dim vComps                  As Variant
    Dim swComp                  As SldWorks.Component2
    Dim swAssy                  As SldWorks.AssemblyDoc
    Dim swBody                  As SldWorks.Body2
    Dim Bodies                  As Variant
    
    ' Set start time
    nStart = Timer
    
    ' папка с  dxf
    subdir_name = TextBox1.Text
     If subdir_name <> "" Then
        On Error Resume Next
        MkDir PathOfDirectory & subdir_name
        On Error GoTo 0
        subdir_name = subdir_name + "\"
    End If
    
    If swModel.GetType = swDocASSEMBLY Then
        Set swAssy = swModel
        vComps = swAssy.GetComponents(False)
        For i = 0 To UBound(vComps)
            Set swComp = vComps(i)
            Set swModel = swComp.GetModelDoc2
            If swComp.GetSuppression <> 0 Then
                'Debug.Print "swModel.NameView: " & swModel.GetPathName & ", CheckBox1.Value:" & CheckBox1.Value & ", swComp.IsHidden: " & swComp.IsHidden(True)
                If swModel.GetType = swDocPART And Not (swComp.IsHidden(True) And CheckBox1.Value) Then
                    Bodies = swModel.GetBodies2(swBodyType_e.swAllBodies, True)
                    Set swBody = Bodies(0)
                    If Not (swBody.IsSheetMetal = 0 And CheckBox2.Value = 0) Then
                        path = swModel.GetPathName
                        filename = Right(path, Len(path) - InStrRev(path, "\"))      ' With extension
                        filename = Left$(filename, InStrRev(filename, ".") - 1)         ' Remove extension
                        bRet = swModel.ExportFlatPatternView(PathOfDirectory & subdir_name & filename & ".DXF", 1)
                        If bRet Then
                            Debug.Print "Successful export " & filename & " to DXF extensioin."
                        Else
                            Debug.Print "UnSuccessful export " & filename & " to DXF extensioin."
                            MsgBox "UnSuccessful export " & filename & " to DXF extensioin."
                        End If
                    Else
                        path = swModel.GetPathName
                        filename = Right(path, Len(path) - InStrRev(path, "\"))      ' With extension
                        filename = Left$(filename, InStrRev(filename, ".") - 1)         ' Remove extension
                        Debug.Print filename & " is not sheet metal."
                    End If
                End If
            End If
        Next i
    ElseIf swModel.GetType = swDocPART Then
        ' geting part name
        path = swModel.GetPathName                                  ' полный_путь+имя_файла+расширение
        filename = Right(path, Len(path) - InStrRev(path, "\"))     ' With extension
        filename = Left$(filename, InStrRev(filename, ".") - 1)     ' Remove extension
        ' ïóòü áåç èìåíè ôàéëà è ðàñøèðåíèÿ
        PathOfDirectory = Strings.Left(path, Strings.Len(path) - Strings.Len(filename) - 7)
        ' Export Flat Pattern without bend (1)
        bRet = swModel.ExportFlatPatternView(PathOfDirectory & subdir_name & filename & ".DXF", 1)
        If bRet Then
            Debug.Print "Successful export " & filename & " to DXF extensioin."
        Else
            Debug.Print "UnSuccessful export " & filename & " to DXF extensioin."
            MsgBox "UnSuccessful export " & filename & " to DXF extensioin."
        End If
    ElseIf swModel.GetType = swDocDRAWING Then
        ' geting part name
        path = swModel.GetPathName                                  ' полный_путь+имя_файла+расширение
        filename = Right(path, Len(path) - InStrRev(path, "\"))     ' With extension
        filename = Left$(filename, InStrRev(filename, ".") - 1)     ' Remove extension
        ' ïóòü áåç èìåíè ôàéëà è ðàñøèðåíèÿ
        PathOfDirectory = Strings.Left(path, Strings.Len(path) - Strings.Len(filename) - 7)
        ' Export dxf
        swModel.SaveAs2 PathOfDirectory & subdir_name & filename & ".DXF", 0, True, False     ' Сохранить файл перезаписав если существует 
    Else
        MsgBox "Not assemble or part or draw."
        End
    End If
    
    ' Calculate total time
    Beep
    MsgBox "Successful export assemble/part/draw to DXF for " & Timer - nStart & " sec"
    'Dim oShell As Object
    'Set oShell = CreateObject("Shell.Application")
    'oShell.Explore (PathOfDirectory)
    
    Debug.Print vbNewLine
    UserForm1.Hide
    
End Sub

Private Sub CommandButton2_Click()
    Unload UserForm1
End Sub
 

[Kelny 1,424]

Так вроде уже задавали вопрос:

https://cccp3d.ru/topic/134959-помогите-пожалуйста-в-дороботки-solidworks-макроса-по-выгрузке-dxf-формата/?tab=comments#comment-1306092

 

Там же было сказано, что нужно выковырять толщину из файла, например, из глобальной переменной, если это листовой металл (или из другого места) и в зависимости от результата выбирать подпапку для сохранения, например, в путь папки добавить значение толщины (нужно найти подходящии функции в API, ниже показан принцип, а не готовое решение):

...

ЗНАЧЕНИЕ_ТОЛЩИНЫ = ФУНКЦИЯ.ВЗЯТЬ_ТОЛЩИНУ_ИЗ_МОДЕЛИ

 ' Export dxf

swModel.SaveAs2 PathOfDirectory & subdir_name & ЗНАЧЕНИЕ_ТОЛЩИНЫ & "\" & filename & ".DXF", 0, True, False     ' Сохранить файл перезаписав если существует 

...

Edited March 9, 2022 by Kelny

[Snake 60 806]

@Operator 1945 Некропостинг, но вдруг пригодится :)

 

[clavr 205]

не реклама. попросил на работе, без проблем купили  DXF-auto для солида. Окупается за неделю, если в пересчете на часы работы конструктора.

Работает все как часы, и очень удобно, удобная настройка вывода и проверка результата с отчетами

[ЮрЮрыч 8]

Здравствуйте. Как вариант из ведомости материалов макросом excell формировать папки материалов (dxf, pdf и перечень на этот материал). При этом еще и отчет писать чтобы увидеть на какие детали чертеж пропустил. 

[Maik812 326]

20.01.2025 в 22:40, Snake 60 сказал:

Некропостинг, но вдруг пригодится

А можно подправить в макросе Geometrika, чтоб толщину деталей подписывал в свойство? Тогда просто отсортировал по толщинам или добавить в имя файла из свойств  и все. 

[Sturmann 34]

20.01.2025 в 22:40, Snake 60 сказал:

@Operator 1945 Некропостинг, но вдруг пригодится :)

 

Вы все это на VBA написали?

[Snake 60 806]

5 часов назад, Sturmann сказал:

Вы все это на VBA написали?

Да, мне всё никак не пересесть на VisualStudio :)

[Sturmann 34]

21.03.2025 в 14:19, Snake 60 сказал:

Да, мне всё никак не пересесть на VisualStudio :)

Сильно конечно. 

[Fedorly 23]

Демонстрация инструмента по сортировке файлов по папкам, в зависимости от свойств

 

Копия видео на рутубе