Загрузка данных
Option Explicit
Sub ReplaceMassDotWithCommaInDrawing()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim massValue As String
Dim resolvedValue As String
Dim newMassText As String
Dim swAnn As SldWorks.Annotation
Dim swNote As SldWorks.Note
Dim notes As Variant
Dim i As Integer
Dim foundInNote As Boolean
Dim sheetName As String
' --- 1. Получаем текущий чертёж ---
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Откройте документ SolidWorks."
Exit Sub
End If
' Проверяем, что это чертёж
If swModel.GetType <> swDocDRAWING Then
MsgBox "Этот макрос работает только на чертеже."
Exit Sub
End If
Set swDraw = swModel
' --- 2. Получаем свойства чертежа ---
Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
If swCustPropMgr Is Nothing Then
MsgBox "Не удалось получить доступ к свойствам чертежа."
Exit Sub
End If
' --- 3. Читаем свойство массы (ищем в пользовательских свойствах чертежа) ---
swCustPropMgr.Get2 "Масса", massValue, resolvedValue
' Если свойство Масса не найдено в чертеже, пробуем получить из ссылочной модели
If resolvedValue = "" Then
MsgBox "Свойство 'Масса' не найдено в свойствах чертежа." & vbCrLf & _
"Попытка получить массу из связанной детали..."
' Получаем первую ссылочную модель (деталь/сборку)
Dim swRefDoc As SldWorks.ModelDoc2
Dim refDocName As String
Dim refDocPath As String
refDocPath = swDraw.GetReferenceModelName(1) ' первая ссылка
If refDocPath <> "" Then
Set swRefDoc = swApp.OpenDoc(refDocPath, swDocPART)
If Not swRefDoc Is Nothing Then
' Получаем свойства ссылочной модели
Dim swRefCustPropMgr As SldWorks.CustomPropertyManager
Set swRefCustPropMgr = swRefDoc.Extension.CustomPropertyManager("")
If Not swRefCustPropMgr Is Nothing Then
swRefCustPropMgr.Get2 "Масса", massValue, resolvedValue
End If
' Закрываем ссылочную модель (не сохраняем)
swApp.CloseDoc refDocPath
End If
End If
If resolvedValue = "" Then
MsgBox "Не удалось найти массу ни в чертеже, ни в связанной детали."
Exit Sub
End If
End If
' --- 4. Заменяем точку на запятую ---
newMassText = Replace(resolvedValue, ".", ",")
' --- 5. Записываем результат в свойство чертежа ---
swCustPropMgr.Add3 "Масса", swCustomInfoType_e.swCustomInfoText, newMassText, swCustomPropertyAddOption_e.swCustomPropertyAddOption_Overwrite
' --- 6. Обновляем все заметки на чертеже, содержащие ссылку на массу ---
Dim swSheet As SldWorks.Sheet
Dim sheetCount As Integer
Dim j As Integer
foundInNote = False
' Получаем количество листов
sheetCount = swDraw.GetSheetCount
For j = 1 To sheetCount
Set swSheet = swDraw.GetSheet(j)
swDraw.ActivateSheet swSheet.GetName
' Получаем все заметки на листе
notes = swSheet.GetNotes
If Not IsEmpty(notes) Then
For i = 0 To UBound(notes)
Set swAnn = notes(i)
' Проверяем, что это заметка
If swAnn.Type = swAnnotationType_e.swNote Then
Set swNote = swAnn.GetSpecificAnnotation
' Проверяем текст заметки на наличие ссылки на массу
Dim noteText As String
noteText = swNote.GetText
' Если в заметке есть ссылка на массу (стандартные форматы)
If InStr(1, noteText, "$PRP:""Масса""", vbTextCompare) > 0 Or _
InStr(1, noteText, "$PRPSHEET:""Масса""", vbTextCompare) > 0 Then
' Обновляем заметку (переустановка текста для обновления ссылки)
swNote.SetText noteText
foundInNote = True
End If
End If
Next i
End If
Next j
' Возвращаемся на первый лист
swDraw.ActivateSheet swDraw.GetSheet(1).GetName
' --- 7. Обновляем модель ---
swModel.ForceRebuild3 False
' --- 8. Выводим сообщение ---
Dim msg As String
msg = "Готово! Масса обновлена, теперь она равна: " & newMassText & " кг"
If foundInNote Then
msg = msg & vbCrLf & "Заметки с ссылкой на массу обновлены."
Else
msg = msg & vbCrLf & "Нет заметок, содержащих ссылку на массу."
End If
MsgBox msg
End Sub