Свойства модели в свойства файла

[VOleg 228]

Всем добрый день. Что-то совсем притупил. Мне надо в файле Ворд все свойства "Обозначение" поменять на "Тема". В тексте, в колонтитулах и свойствах файла.

сп1.dot

[brigval 723]

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

Всем добрый день. Что-то совсем притупил. Мне надо в файле Ворд все свойства "Обозначение" поменять на "Тема". В тексте, в колонтитулах и свойствах файла.

сп1.dot 113 \u041a\u0431 · 0 скачиваний

Что такое свойство "Обозначение"? Так?

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

Вот свойства шаблона.

Там нет свойства "Обозначение"

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

 

Изменено 23 марта пользователем brigval

[VOleg 228]

Все есть

[Snake 60 757]

@VOleg

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

Сам файл: CODE ECS2.dot

[VOleg 228]

Это выше моего понимания.

а ведь дальше будет замена наименования на название.

[Snake 60 757]

2 минуты назад, VOleg сказал:

а ведь дальше будет замена наименования на название.

Я же записал на видео сам процесс замены свойства, в чём возникла трудность понимания?

[VOleg 228]

В моей бестолковке

[Snake 60 757]

39 минут назад, VOleg сказал:

В моей бестолковке

Давайте тогда попробую описать последовательность замены свойства на примере Наименование на Название по шагам:

1) Нажимаем ПКМ на имени файла шаблона, выбираем Свойства и переходим на вкладку Особые

2) Выделяем свойство Наименование и нажимаем кнопку Удалить (после этого при открытии файла увидим Ошибка! Неизвестное имя свойства документа! тем самым увидим где конкретно это свойство применялось)

3) На этой же вкладке создаем новое свойство Имя: Название; Тип: Текстовый; (в поле Значение: ставим пробел иначе не будет активна кнопка Добавить) и жмем кнопку Добавить

4) Открываем документ и видим описанную выше ошибку:

5) Редактируем колонтитул, т.к данное свойство именно в нем в данном случае (При замене свойства Обозначение оно применялось в двух местах, поэтому заменяли в двух местах)

6) ЛКМ на ошибке - выделяем свойство, далее ПКМ на выделенном свойстве и выбираем пункт Изменить поле...

7) Откроется окно:

8) Листаем вниз и находим наше свойство Название (все свойства отсортированы по алфавиту):

9) Жмём кнопку ОК и видим что ошибка исчезла - свойство переназначено:

10) Выходим из редактирования колонтитула и пересохраняем документ в формате шаблона:

11) Проверяем что свойство работает, для этого присваиваем ему Какое-либо значение:

12) Открываем документ:

 

[VOleg 228]

Пункты 1 и 2 без проблем.

А вот 3 пункт - нужное мне свойство уже есть

Именно оно-то мне и нужно и Тема уже есть вместо Обозначения.

[VOleg 228]

Администраторов прошу убрать дерьмо №812 из моей темы.

[Snake 60 757]

@VOleg Где находятся вкладки, что на последнем скрине?

@VOleg Всё, я понял что Вам надо(:

[VOleg 228]

1 час назад, Snake 60 сказал:

@VOleg Где находятся вкладки, что на последнем скрине?

@VOleg Всё, я понял что Вам надо(:

 

 

 

Я перебрал все свойства, все вкладки и получил результат с Subject и Title. Огромное спасибо за помощь.

Теперь переходим к Эксель.

сп1.dot

Итак, создал чертеж, на нем спецификацию по ЕСКД, ТТ связал с номерами позиций. 

И хочу эту спецификацию в Эксель сохранить на диск.

 

 

Администратору сайте ОГРОМНОЕ спасибо!!!!!!

Изменено 24 марта пользователем VOleg

[VOleg 228]

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

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

В свойствах файла спецификации должны быть записаны Тема/Subject и Название/Title со значениями Обозначения и Наименования чертежа/модели.

 

[VOleg 228]

После сохранения в Эксель, спецификация сохраняется в Ворд с использованием выше откорректированного шаблона, по тем же правилам.

Макрос создания спецификации Ворд из Эксель

МАКРОС.docx

[Snake 60 757]

24.03.2024 в 04:28, VOleg сказал:

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

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

В свойствах файла спецификации должны быть записаны Тема/Subject и Название/Title со значениями Обозначения и Наименования чертежа/модели.

С сохранением таблицы Экселя в том виде, в котором создает ее солид возникли проблемы. Не нашел как это сделать средствами АПИ, может быть более опытные коллеги подскажут как это сделать. Максимум что удалось найти макрос который сохраняет спецуху как текст через файл csv и разделитель "," (запятая) отсюда вытекает ограничение, что в именах файлов и в именах и значениях свойств не должно быть запятых, а это ппц как не правильно. За этим просто не уследишь. Остальное, вроде бы реализовал. Выкладываю для тестов ниже.

Цитата

 

' Необходимо подключить следующие библиотеки:
' SolidWorks 20xx Type Library
' SolidWorks 20xx Constant Type Library
' Microsoft Excel XX.0 Object Libary

' Заменить xx установленную у вас версию SolidWorks и XX - версия Office

 

Option Explicit

' Макрос создан by Declan Brogan откорректирован и переведен Дербуш Олег aka Snake 60
' Данный макрос создает файл Excel с расширением .xls из файла спецификации на чертеже
' Добавляет в свойство созданного Excel файла в поле Название значение свойства Наименования
' а в поле Тема - значение свойства Обозначение взятые из свойств модели/сборки


' Перед выполнением макроса должен быть открыт чертеж на котором есть спецификация
' В модели сборки должны быть заполнены свойства Наименование и Обозначение для записи их в Тему и Название

' Необходимо подключить следующие библиотеки:
' SolidWorks 20xx Type Library
' SolidWorks 20xx Constant Type Library
' Microsoft Excel XX.0 Object Libary

' Заменить xx установленную у вас версию SolidWorks и XX - версия Office

Dim strTitleForExcel As String
Dim strSubjectForExcel As String

Sub main()

    On Error GoTo ErrH:
    
    Dim swApp                       As SldWorks.SldWorks
    Dim swModelDoc             As SldWorks.ModelDoc2
    Dim swSelMgr                  As SldWorks.SelectionMgr
    Dim swTableAnn              As SldWorks.TableAnnotation
    Dim swBomFeature          As SldWorks.BomFeature
    Dim swAnn                       As SldWorks.Annotation
    Dim vTableArr                   As Variant
    Dim vTable                        As Variant
    Dim retval                          As Boolean
    Dim CSVFile                     As String
    
    Set swApp = Application.SldWorks

    Set swModelDoc = swApp.ActiveDoc
    
    Set swSelMgr = swModelDoc.SelectionManager
        
    ' Здесь автор давал коментарий как правильно выбрать специю в дереве по имени
    ' но я переписал этот участок кода и теперь специя выбирается по типу фичерса и не зависит от имени
    ' это более универсальный подход требующий от пользователя меньших телодвижений
    TraverseFeatureTree
     
    ' Выбор таблицы спецификации
    Set swBomFeature = swSelMgr.GetSelectedObject5(1)
   
    ' Убеждаемся что таблица спецификации выбрана
    If swBomFeature Is Nothing Then
    
        MsgBox "Для экспорта спецификации добавьте ее в чертеж!"
        Exit Sub
    
    End If
  
    vTableArr = swBomFeature.GetTableAnnotations
        
    For Each vTable In vTableArr
        
        ' получаем специю как объект table annotation
        Set swTableAnn = vTable

    Next vTable
        
    ' переименовываем специю для сохранения в файл .csv
    CSVFile = RenameBomToCSV
    
    
    ' Сохраняем csv файл.
    ' Здесь мы сохраняем csv файл без вывода каких-либо сообщений и всплывающих окон
    retval = swTableAnn.SaveAsText2(CSVFile, ",", True)
    
    ' Теперь меняем расширение на .xls и сохраняем
    SaveCSVAsXLS CSVFile
    
    ' Удаляем ненужный файл .csv
    DeleteFile (CSVFile)
    
    ' Процесс завершен
    MsgBox "Спецификация сохранена!"
    
    
    ' Очистка переменных
    Set swBomFeature = Nothing
    Set swModelDoc = Nothing
    Set swApp = Nothing
    
ErrH:
    
    If Err.Number = 0 Or Err.Number = 20 Then
    
        Resume Next
        
    Else
    
        ' Несоответствие типов (ошибка 13)
        If swBomFeature Is Nothing Then
    
            MsgBox "Спецификация в дереве не обнаружена, добавьте ее!"
            Exit Sub
    
        Else
    
            MsgBox Err.Number & " " & Err.Description
        
        End If
    
    End If
    
End Sub

' Траверсинг дерева элементов
Sub TraverseFeatureTree()
    
    Dim swApp As SldWorks.SldWorks
    Dim swModelDoc As SldWorks.ModelDoc2
    Dim swFeature As SldWorks.Feature
    Dim ModelDocType As Long
    Dim FeatureName As String
    Dim FeatureType As String
 
    ' Подключаемся к SW
    Set swApp = Application.SldWorks
    
    ' Получаем активный документ
    Set swModelDoc = swApp.ActiveDoc
    
    ' Сброс каких-либо выделенных элементов
    swModelDoc.ClearSelection
    
    ' Получаем тип документа
    ModelDocType = swModelDoc.GetType
    
    ' Получаем первый элемент в дереве элементов
    Set swFeature = swModelDoc.FirstFeature
    
    Debug.Print "Список элементов дерева: "
    
        ' Запуск траверсинга
        While Not swFeature Is Nothing

            FeatureName = swFeature.Name
            FeatureType = swFeature.GetTypeName2

            Debug.Print "     Имя: """; FeatureName; """ ; Тип: """; FeatureType; """"
                
                ' Do what you want here. I just searched the feature tree for a BOM called Bill of Materials2
                ' Change "Bill of Materials2" to the BOM of your choice
'                If FeatureName = "Спецификация1" Or FeatureName = "Спецификация2" Or FeatureName = "Спецификация3" Then
            If FeatureType = "BomFeat" Then
                    ' выбор специи
                    swFeature.Select True
                    
                    ' выход из подпрограммы
                    Exit Sub
                
                End If
        
            ' получаем следующий элемент
            Set swFeature = swFeature.GetNextFeature
        
        Wend
    
End Sub

Function RenameBomToCSV() As String
      
    Dim swApp         As SldWorks.SldWorks
    
    Dim swModelDoc    As SldWorks.ModelDoc2
    
    Dim GetPath       As String
    
    'очистка строки
    RenameBomToCSV = ""
    
    Set swApp = Application.SldWorks

    Set swModelDoc = swApp.ActiveDoc
    
    'получаем полный путь к активному документу
    GetPath = swModelDoc.GetPathName
    
    'убираем расширение файла solidworks
    GetPath = VBA.Left(GetPath, Len(GetPath) - 6)
    
    'добавляем расширение csv файла
    GetPath = GetPath & "csv"
    
    RenameBomToCSV = GetPath
    
    'очистка переменных
    Set swModelDoc = Nothing
    Set swApp = Nothing

End Function
' Pass in the CSV file
Sub SaveCSVAsXLS(WhichDoc As String)
    
    Dim xlApp As Excel.Application

    Dim xlWB  As Excel.Workbook

    Dim FileToKill As String
    
    ' If there is an existing file the it will get deleted
    FileToKill = VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls"
    
    Debug.Print FileToKill
    
    
    If Dir(FileToKill) <> "" Then
    
        ' Kill the existing file to stop a message popping up
        ' File already exists do you want to replace it
        ' This just make it a bit slicker
        Kill FileToKill
        
        Set xlApp = CreateObject("Excel.Application")
    
        xlApp.Visible = False
        
        ' Open the CSV file
        Set xlWB = xlApp.Workbooks.Open(WhichDoc)
        
        ' and save as xls
        xlWB.SaveAs VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls", 56
        
        xlWB.BuiltinDocumentProperties("Title") = GetPropertiesFromModel(strTitleForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Title")
        xlWB.BuiltinDocumentProperties("Subject") = GetPropertiesFromModel(strSubjectForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Subject")
        xlWB.Save
        xlWB.Close
        
        ' Show the xls file
'        xlApp.Visible = True
        
    Else
        
        Set xlApp = CreateObject("Excel.Application")
    
        xlApp.Visible = False

        Set xlWB = xlApp.Workbooks.Open(WhichDoc)
    
        xlWB.SaveAs VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls", 56
       Set xlWB = xlApp.Workbooks.Open(VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls")
        
        xlWB.BuiltinDocumentProperties("Title") = GetPropertiesFromModel(strTitleForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Title")
        xlWB.BuiltinDocumentProperties("Subject") = GetPropertiesFromModel(strSubjectForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Subject")
        xlWB.Save
        xlWB.Close
        
        ' Show the xls file
'        xlApp.Visible = True
    
    End If
    
End Sub
Sub DeleteFile(DeleteWhichFile As String)

    Kill DeleteWhichFile

End Sub

Function GetPropertiesFromModel(strProperty As String) As String

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swSheet As SldWorks.Sheet
Dim swRefModel As SldWorks.ModelDoc2
Dim swCustProp As CustomPropertyManager
Dim swConfig As SldWorks.Configuration
Dim viewConfigName As String
Dim swSelMgr As SldWorks.SelectionMgr
Dim vSheetProps As Variant
Dim bRet As Boolean
Dim bool As Boolean
Dim Format As String
Dim nErr As Long, nWarn As Long
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    On Error GoTo Err_Message
    
    Set swSelMgr = swModel.SelectionManager
    Set swDraw = swModel
    Set swSheet = swDraw.GetCurrentSheet
    vSheetProps = swSheet.GetProperties

    Set swView = swDraw.GetFirstView 'получаем первый вид, но первый вид - это весь Лист целиком
    Set swView = swView.GetNextView 'переключаемся на следующий вид - это первый вид на листе

    Set swRefModel = swView.ReferencedDocument
    
    Set swConfig = swRefModel.GetConfigurationByName(viewConfigName)
            viewConfigName = swView.ReferencedConfiguration
            
    Set swCustProp = swRefModel.Extension.CustomPropertyManager(viewConfigName)

Select Case strProperty
     Case strTitleForExcel
            bool = swCustProp.Get5("Наименование", False, strProperty, GetPropertiesFromModel, True)
     Case strSubjectForExcel
             bool = swCustProp.Get5("Обозначение", False, strProperty, GetPropertiesFromModel, True)
    Case Else
            GetPropertiesFromModel = ""
               swApp.SendMsgToUser2 "Нужное свойство не найдено в модели!", swMbInformation, swMbOk
End Select
        
    Exit Function
Err_Message:
    swApp.SendMsgToUser2 "Пожалуйста, откройте чертеж!", swMbWarning, swMbOk
End Function

 

[Snake 60 757]

@Snake 60  ААААААААААААА..... я сделал это Тезка, с тебя магарыч При копировании и вставки кода убедись, что раскладка на русском, иначе крякозябры. И обязательно подключить библиотеку Микрософт Экселя (Tools-References выбрать из списка и торкнуть галку на Microsoft Excel XX.0 Object Libary) иначе не заработает

Option Explicit

' Макрос создан by Declan Brogan откорректирован и переведен Дербуш Олег aka Snake 60
' Данный макрос создает файл Excel с расширением .xlsx из файла спецификации на чертеже
' Добавляет в свойство созданного Excel файла в поле Название значение свойства Наименования
' а в поле Тема - значение свойства Обозначение взятые из свойств модели/сборки

' Перед выполнением макроса должен быть открыт чертеж на котором есть спецификация
' В модели сборки должны быть заполнены свойства Наименование и Обозначение для записи их в Тему и Название

' Необходимо подключить следующие библиотеки:
' SolidWorks 20xx Type Library
' SolidWorks 20xx Constant Type Library
' Microsoft Excel XX.0 Object Libary

' Заменить xx установленную у вас версию SolidWorks и XX - версия Office

Dim strTitleForExcel As String
Dim strSubjectForExcel As String

Sub main()

    On Error GoTo ErrH:
    
    Dim swApp                       As SldWorks.SldWorks
    Dim swModelDoc             As SldWorks.ModelDoc2
    Dim swSelMgr                  As SldWorks.SelectionMgr
    Dim swTableAnn              As SldWorks.TableAnnotation
    Dim swBomFeature          As SldWorks.BomFeature
    Dim swAnn                       As SldWorks.Annotation
    Dim vTableArr                   As Variant
    Dim vTable                        As Variant
    Dim retval                          As Boolean
    Dim CSVFile                     As String
    Dim swBOMAnnotation    As SldWorks.BomTableAnnotation
    Set swApp = Application.SldWorks

    Set swModelDoc = swApp.ActiveDoc
    
    Set swSelMgr = swModelDoc.SelectionManager
        
    ' Здесь автор давал коментарий как правильно выбрать специю в дереве по имени
    ' но я переписал этот участок кода и теперь специя выбирается по типу фичерса и не зависит от имени
    ' это более универсальный подход требующий от пользователя меньших телодвижений
    TraverseFeatureTree
     
    ' Выбор таблицы спецификации
    Set swBomFeature = swSelMgr.GetSelectedObject5(1)
   
    ' Убеждаемся что таблица спецификации выбрана
    If swBomFeature Is Nothing Then
    
        MsgBox "Для экспорта спецификации добавьте ее в чертеж!"
        Exit Sub
    
    End If
  
    vTableArr = swBomFeature.GetTableAnnotations
        
    For Each vTable In vTableArr
        
        ' получаем специю как объект table annotation
        Set swTableAnn = vTable
        Set swBOMAnnotation = vTable

    Next vTable
        
    ' переименовываем специю для сохранения в файл .csv
    CSVFile = RenameBomToCSV
    
    
    ' Сохраняем csv файл.
    ' Здесь мы сохраняем csv файл без вывода каких-либо сообщений и всплывающих окон

'    retval = swTableAnn.SaveAsText2(CSVFile, ",", True)
     retval = swBOMAnnotation.SaveAsExcel(CSVFile, False, False)
    
    ' Теперь меняем расширение на .xls и сохраняем
    SaveCSVAsXLS CSVFile
    
    ' Удаляем ненужный файл .csv
'    DeleteFile (CSVFile)
    
    ' Процесс завершен
    MsgBox "Спецификация сохранена!"
    
    
    ' Очистка переменных
    Set swBomFeature = Nothing
    Set swModelDoc = Nothing
    Set swApp = Nothing
    
ErrH:
    
    If Err.Number = 0 Or Err.Number = 20 Then
    
        Resume Next
        
    Else
    
        ' Несоответствие типов (ошибка 13)
        If swBomFeature Is Nothing Then
    
            MsgBox "Спецификация в дереве не обнаружена, добавьте ее!"
            Exit Sub
    
        Else
    
            MsgBox Err.Number & " " & Err.Description
        
        End If
    
    End If
    
End Sub

' Траверсинг дерева элементов
Sub TraverseFeatureTree()
    
    Dim swApp As SldWorks.SldWorks
    Dim swModelDoc As SldWorks.ModelDoc2
    Dim swFeature As SldWorks.Feature
    Dim ModelDocType As Long
    Dim FeatureName As String
    Dim FeatureType As String
 
    ' Подключаемся к SW
    Set swApp = Application.SldWorks
    
    ' Получаем активный документ
    Set swModelDoc = swApp.ActiveDoc
    
    ' Сброс каких-либо выделенных элементов
    swModelDoc.ClearSelection
    
    ' Получаем тип документа
    ModelDocType = swModelDoc.GetType
    
    ' Получаем первый элемент в дереве элементов
    Set swFeature = swModelDoc.FirstFeature
    
    Debug.Print "Список элементов дерева: "
    
        ' Запуск траверсинга
        While Not swFeature Is Nothing

            FeatureName = swFeature.Name
            FeatureType = swFeature.GetTypeName2

            Debug.Print "     Имя: """; FeatureName; """ ; Тип: """; FeatureType; """"
                
                ' Do what you want here. I just searched the feature tree for a BOM called Bill of Materials2
                ' Change "Bill of Materials2" to the BOM of your choice
'                If FeatureName = "Спецификация1" Or FeatureName = "Спецификация2" Or FeatureName = "Спецификация3" Then
            If FeatureType = "BomFeat" Then
                    ' выбор специи
                    swFeature.Select True
                    
                    ' выход из подпрограммы
                    Exit Sub
                
                End If
        
            ' получаем следующий элемент
            Set swFeature = swFeature.GetNextFeature
        
        Wend
    
End Sub

Function RenameBomToCSV() As String
      
    Dim swApp         As SldWorks.SldWorks
    
    Dim swModelDoc    As SldWorks.ModelDoc2
    
    Dim GetPath       As String
    
    'очистка строки
    RenameBomToCSV = ""
    
    Set swApp = Application.SldWorks

    Set swModelDoc = swApp.ActiveDoc
    
    'получаем полный путь к активному документу
    GetPath = swModelDoc.GetPathName
    
    'убираем расширение файла solidworks
    GetPath = VBA.Left(GetPath, Len(GetPath) - 6)
    
    'добавляем расширение csv файла
'    GetPath = GetPath & "csv"
    GetPath = GetPath & "xlsx"
    
    RenameBomToCSV = GetPath
    
    'очистка переменных
    Set swModelDoc = Nothing
    Set swApp = Nothing

End Function
' Pass in the CSV file
Sub SaveCSVAsXLS(WhichDoc As String)
    
    Dim xlApp As Excel.Application

    Dim xlWB  As Excel.Workbook

    Dim FileToKill As String
    
    ' If there is an existing file the it will get deleted
'    FileToKill = VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls"
    
    Debug.Print FileToKill
    
    
    If Dir(FileToKill) <> "" Then
    
        ' Kill the existing file to stop a message popping up
        ' File already exists do you want to replace it
        ' This just make it a bit slicker
'        Kill FileToKill
        
        Set xlApp = CreateObject("Excel.Application")
    
        xlApp.Visible = False
        
        ' Open the CSV file
        Set xlWB = xlApp.Workbooks.Open(WhichDoc)
        
        ' and save as xls
'        xlWB.SaveAs VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls", 56
        
        xlWB.BuiltinDocumentProperties("Title") = GetPropertiesFromModel(strTitleForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Title")
        xlWB.BuiltinDocumentProperties("Subject") = GetPropertiesFromModel(strSubjectForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Subject")
        xlWB.Save
        xlWB.Close
        
        ' Show the xls file
'        xlApp.Visible = True
        
    Else
        
        Set xlApp = CreateObject("Excel.Application")
    
        xlApp.Visible = False

        Set xlWB = xlApp.Workbooks.Open(WhichDoc)
    
'        xlWB.SaveAs VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls", 56
'       Set xlWB = xlApp.Workbooks.Open(VBA.Left(WhichDoc, Len(WhichDoc) - 3) & "xls")
        
        xlWB.BuiltinDocumentProperties("Title") = GetPropertiesFromModel(strTitleForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Title")
        xlWB.BuiltinDocumentProperties("Subject") = GetPropertiesFromModel(strSubjectForExcel)
        Debug.Print xlWB.BuiltinDocumentProperties("Subject")
        xlWB.Save
        xlWB.Close
        
        ' Show the xls file
'        xlApp.Visible = True
    
    End If
    
End Sub

'Sub DeleteFile(DeleteWhichFile As String)
'
'    Kill DeleteWhichFile
'
'End Sub

Function GetPropertiesFromModel(strProperty As String) As String

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swSheet As SldWorks.Sheet
Dim swRefModel As SldWorks.ModelDoc2
Dim swCustProp As CustomPropertyManager
Dim swConfig As SldWorks.Configuration
Dim viewConfigName As String
Dim swSelMgr As SldWorks.SelectionMgr
Dim vSheetProps As Variant
Dim bRet As Boolean
Dim bool As Boolean
Dim Format As String
Dim nErr As Long, nWarn As Long
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    On Error GoTo Err_Message
    
    Set swSelMgr = swModel.SelectionManager
    Set swDraw = swModel
    Set swSheet = swDraw.GetCurrentSheet
    vSheetProps = swSheet.GetProperties

    Set swView = swDraw.GetFirstView 'получаем первый вид, но первый вид - это весь Лист целиком
    Set swView = swView.GetNextView 'переключаемся на следующий вид - это первый вид на листе

    Set swRefModel = swView.ReferencedDocument
    
    Set swConfig = swRefModel.GetConfigurationByName(viewConfigName)
            viewConfigName = swView.ReferencedConfiguration
            
    Set swCustProp = swRefModel.Extension.CustomPropertyManager(viewConfigName)

Select Case strProperty
     Case strTitleForExcel
            bool = swCustProp.Get5("Наименование", False, strProperty, GetPropertiesFromModel, True)
     Case strSubjectForExcel
             bool = swCustProp.Get5("Обозначение", False, strProperty, GetPropertiesFromModel, True)
    Case Else
            GetPropertiesFromModel = ""
               swApp.SendMsgToUser2 "Нужное свойство не найдено в модели!", swMbInformation, swMbOk
End Select
        
    Exit Function
Err_Message:
    swApp.SendMsgToUser2 "Пожалуйста, откройте чертеж!", swMbWarning, swMbOk
End Function

 

[malvi.dp 293]

03.04.2024 в 22:30, Snake 60 сказал:

 С сохранением таблицы Экселя в том виде, в котором создает ее солид возникли проблемы. Не нашел как это сделать средствами АПИ

Возможно, будет полезно - макрос сохраняет выбранную таблицу в Эксель, без промежуточного файла csv.

BOM to EXCEL_R.swp

[Snake 60 757]

19 минут назад, malvi.dp сказал:

Возможно, будет полезно - макрос сохраняет выбранную таблицу в Эксель, без промежуточного файла csv.

Спасибо, гляну. Но в последней версии макроса как раз сохраняется на прямую, без промежуточного файла, просто остались комменты от предыдущего метода. )

[malvi.dp 293]

2 часа назад, Snake 60 сказал:

Спасибо, гляну. Но в последней версии макроса как раз сохраняется на прямую, без промежуточного файла

Тестировал на 16 и 20 версиях.

20 норм.

На 16 отрабатывает с ошибкой

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

Скорее всего проблема в этой строке

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

 

[Snake 60 757]

@malvi.dp Да скорее всего, из-за этого и были танцы с бубном с сохранением через CSV файл.