подскажите макрос

[DuS 328]

Уважаемые коллеги! 

Нужен макрос делающий следующее:

1. делает выделенную деталь  сборки виртуальной

2. переименовывает деталь, добавляя суффикс имя сборки (например  "имя детали_имя сборки")

3. сохраняет эту деталь во внешний файл в папку со сборкой .

 

 

 

ЗЫ прошу не отвечать по типу " да нафига тебе это надо лучше сделай так то или так то".

[Kelny 1 293]

Есть переименование деталей через дерево в сборке (но там нет виртулизации и суффиксов): http://www.streamdivision.com/pereimenovanie-detaley/

[DuS 328]

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

 

Есть переименование деталей через дерево в сборке (но там нет виртулизации и суффиксов): http://www.streamdivision.com/pereimenovanie-detaley/

[streamdown 1 565]

@@DuS, это можно сделать.

[DuS 328]

@@DuS, это можно сделать.

Я догадывался)) Только я не владею vba.

[artem_cad 89]

Я догадывался)) Только я не владею vba.

 

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

 

Попробуйте макрос ниже. Минимально поддерживаемая версия 2013:

 

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2

Sub main()

    Set swApp = Application.SldWorks
    
    Set swModel = swApp.ActiveDoc
    
    Set swAssy = swModel
    
    Set swSelMgr = swModel.SelectionManager
    
    Set swComp = swSelMgr.GetSelectedObject6(1, -1)
    
    Dim compName As String
    Dim ext As String
    
    GetDirectoryPath swComp.GetPathName(), compName, ext
    
    Dim outPath As String
    Dim assmName As String
    outPath = GetDirectoryPath(swModel.GetPathName(), assmName, "")
    
    compName = compName & "_" & assmName
    swComp.MakeVirtual
    swComp.Name2 = compName
    
    swComp.SaveVirtualComponent outPath & compName & ext
    
End Sub

Function GetDirectoryPath(filePath As String, ByRef fileName As String, ByRef extension As String) As String
    
    Const SW_EXT_PATTERN = ".SLDXXX"
    
    GetDirectoryPath = Left(filePath, InStrRev(filePath, "\"))
    fileName = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
    extension = Right(filePath, Len(SW_EXT_PATTERN))
    
End Function

~A.

[DuS 328]

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

 

Попробуйте макрос ниже. Минимально поддерживаемая версия 2013:

 

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2

Sub main()

    Set swApp = Application.SldWorks
    
    Set swModel = swApp.ActiveDoc
    
    Set swAssy = swModel
    
    Set swSelMgr = swModel.SelectionManager
    
    Set swComp = swSelMgr.GetSelectedObject6(1, -1)
    
    Dim compName As String
    Dim ext As String
    
    GetDirectoryPath swComp.GetPathName(), compName, ext
    
    Dim outPath As String
    Dim assmName As String
    outPath = GetDirectoryPath(swModel.GetPathName(), assmName, "")
    
    compName = compName & "_" & assmName
    swComp.MakeVirtual
    swComp.Name2 = compName
    
    swComp.SaveVirtualComponent outPath & compName & ext
    
End Sub

Function GetDirectoryPath(filePath As String, ByRef fileName As String, ByRef extension As String) As String
    
    Const SW_EXT_PATTERN = ".SLDXXX"
    
    GetDirectoryPath = Left(filePath, InStrRev(filePath, "\"))
    fileName = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
    extension = Right(filePath, Len(SW_EXT_PATTERN))
    
End Function

~A.

Спасибо! Сейчас попробую.

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

[Kelny 1 293]

у меня подозрение что я не туда текст вставляю.

Открываете/создаёте макрос  и заменяете весь текст. Например создаёте новый проект VBA (*.swp):

 

Dim swApp As Object
Sub main()

Set swApp = Application.SldWorks
End Sub

заменяете имеющийся код предложенным кодом.

[DuS 328]

Открываете/создаёте макрос  и заменяете весь текст. Например создаёте новый проект VBA (*.swp):

заменяете имеющийся код предложенным кодом.

 

Супер!!!! Работает!  Спасибо!!!!

Единственное пожелание, если деталь не выбрана возникает ошибка. Сделать бы окошко с текстом "выберите элемент".

[artem_cad 89]

Вот ссылка: (сделал, чтобы выводилось сообщение об ошибке) http://cloud.ic3d.com.au/RenameComponent.swp. Только ошибка на английском, откройте макрос и замените текст (Инструмент-Макрос-Редактировать). У меня макросы не поддерживают юникод почему-то.

Изменено 10 декабря 2015 пользователем artem_cad

[DuS 328]

Вот ссылка: (сделал, чтобы выводилось сообщение об ошибке) http://cloud.ic3d.com.au/RenameComponent.swp. Только ошибка на английском, откройте макрос и замените текст (Инструмент-Макрос-Редактировать). У меня макросы не поддерживают юникод почему-то.

Спасибо! Отлично работает. Потестил даже на файле чертежа, пишет откройте сборку. Это очень хорошо!

Еще раз спасибо!

Вот ссылка на картинку для макроса.

https://yadi.sk/d/98bFdK7tm83rF

Изменено 10 декабря 2015 пользователем DuS