[МишаИнженер]

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

Код:

[Выделить все]

Public Sub ПодготовитьЧертёжДляWord()
'Функция подготавливает чертёж для World
Dim intНомОбъекта As Integer, objСтильТекста As AcadTextStyle, objСтильРазмеров As AcadDimStyle, objОбъект As AcadEntity
Dim strТекст As String, objБлок As AcadBlock, intНомБлока As Integer
Dim colСписокУдалОбъектов As Collection
On Error GoTo ОбработкаОшибок
'Заменим во всех текстовых стилях шрифт на Times New Roman
   For intНомОбъекта = 0 To ThisDrawing.TextStyles.Count - 1
      Set objСтильТекста = ThisDrawing.TextStyles(intНомОбъекта)
      objСтильТекста.fontFile = "Times.ttf"
   Next intНомОбъекта
'Заменим во всех размерных стилях цвет на белый
   For intНомОбъекта = 0 To ThisDrawing.DimStyles.Count - 1
      Set objСтильРазмеров = ThisDrawing.DimStyles(intНомОбъекта)
      Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCLRT", "7", objСтильРазмеров)
   Next intНомОбъекта
   For intНомБлока = 0 To ThisDrawing.Blocks.Count - 1
      Set objБлок = ThisDrawing.Blocks(intНомБлока)
      Set colСписокУдалОбъектов = New Collection
   'Изменим цвет каждого объекта в чертеже на тёмный
      For intНомОбъекта = 0 To objБлок.Count - 1
         Set objОбъект = objБлок(intНомОбъекта)
         objОбъект.color = acWhite
         If InStr(1, UCase(objОбъект.ObjectName), "TEXT") > 0 Then
            strТекст = objОбъект.TextString
            strТекст = Replace(strТекст, "{\C14;", "")
            objОбъект.TextString = strТекст
            objОбъект.color = acWhite
            objОбъект.Update
         ElseIf InStr(1, UCase(objОбъект.ObjectName), "WIPEOUT") > 0 Then
            colСписокУдалОбъектов.Add objОбъект
         End If
      Next intНомОбъекта
      Do While colСписокУдалОбъектов.Count > 0
         colСписокУдалОбъектов(colСписокУдалОбъектов.Count).Delete
         colСписокУдалОбъектов.Remove (colСписокУдалОбъектов.Count)
      Loop
   Next intНомБлока
'Выведем сообщение о выполненной работе
   MsgBox "Чертёж подготовлен для вставки в Word", vbInformation, gstrНазваниеПрограммы
   Exit Sub
ОбработкаОшибок:
   MsgBox "При подготовке чертежа для Word произошла ошибка!" & vbLf & vbLf & _
          "Название ошибки: " & Err.Description & vbLf & vbLf & _
          "Номер ошибки = " & Err.Number, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

Но эта функция не влияет на атрибуты уже вставленных блоков.
Как с помощью VBA можно поменять цвет атрибутов уже вставленных блоков с атрибутами?

[TararykovDG]

МишаИнженер, в твоем коде обрабатываются описания блоков, а соответственно и описания атрибутов блоков, и в описании цвет атрибутов как раз меняется. А вот чтобы цвет поменялся и во всех вхождения необходимо "синхронизировать" атрибуты. Попробуй после выполнения твоего кода набрать в ком. строке ACada команду _attsync, потом выбрать на чертеже какое-нибудь вхождение блока и нажать Enter и все вхождения выбранного блока обновятся, в том числе и цвет атрибутов. Но здесь есть маленькая проблема, вместе с цветом у атрибутов обновятся и остальные настройки в соответствии с описанием, например точка вставки атрибута относительно точки вставки блока, а у каждого атрибута в каждом вхождении блока она может быть индивидуальная. Поэтому лучше перебрать все вхождения блоков на чертеже и поменять цвет для каждого атрибута в каждом вхождении. Попробуй такой код, в нем красным цветом выделено то что было добавлено в твой исходный код:

Код:

[Выделить все]

Public Sub ПодготовитьЧертёжДляWord()
'Функция подготавливает чертёж для World
Dim intНомОбъекта As Integer, objСтильТекста As AcadTextStyle, objСтильРазмеров As AcadDimStyle, objОбъект As AcadEntity
Dim strТекст As String, objБлок As AcadBlock, intНомБлока As Integer
Dim colСписокУдалОбъектов As Collection
On Error GoTo ОбработкаОшибок
'Заменим во всех текстовых стилях шрифт на Times New Roman
   For intНомОбъекта = 0 To ThisDrawing.TextStyles.Count - 1
      Set objСтильТекста = ThisDrawing.TextStyles(intНомОбъекта)
      objСтильТекста.fontFile = "Times.ttf"
   Next intНомОбъекта
'Заменим во всех размерных стилях цвет на белый
   For intНомОбъекта = 0 To ThisDrawing.DimStyles.Count - 1
      Set objСтильРазмеров = ThisDrawing.DimStyles(intНомОбъекта)
      Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCLRT", "7", objСтильРазмеров)
   Next intНомОбъекта
   For intНомБлока = 0 To ThisDrawing.Blocks.Count - 1
      Set objБлок = ThisDrawing.Blocks(intНомБлока)
      Set colСписокУдалОбъектов = New Collection
   'Изменим цвет каждого объекта в чертеже на тёмный
      For intНомОбъекта = 0 To objБлок.Count - 1
         Set objОбъект = objБлок(intНомОбъекта)
         objОбъект.color = acWhite
         If InStr(1, UCase(objОбъект.ObjectName), "TEXT") > 0 Then
            strТекст = objОбъект.TextString
            strТекст = Replace(strТекст, "{\C14;", "")
            objОбъект.TextString = strТекст
            objОбъект.color = acWhite
            objОбъект.Update
         ElseIf InStr(1, UCase(objОбъект.ObjectName), "WIPEOUT") > 0 Then
            colСписокУдалОбъектов.Add objОбъект
         End If
      Next intНомОбъекта
      Do While colСписокУдалОбъектов.Count > 0
         colСписокУдалОбъектов(colСписокУдалОбъектов.Count).Delete
         colСписокУдалОбъектов.Remove (colСписокУдалОбъектов.Count)
      Loop
   Next intНомБлока
   '------------------------
   Dim ssetObj As AcadSelectionSet
   Set ssetObj = ThisDrawing.SelectionSets.Add("sset_insert")
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   gpCode(0) = 0
   dataValue(0) = "Insert"
   
   Dim groupCode As Variant, dataCode As Variant
   groupCode = gpCode
   dataCode = dataValue

   ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
   
   Dim blockRefObj As AcadBlockReference
   Dim varAttributes As Variant
   Dim I As Integer, J As Integer
   For I = 0 To ssetObj.Count - 1
     Set blockRefObj = ssetObj.Item(I)
     varAttributes = blockRefObj.GetAttributes
     For J = LBound(varAttributes) To UBound(varAttributes)
        varAttributes(J).color = acBlue ' здесь подставь нужный цвет
     Next J
   Next I
   
   ssetObj.Delete
   '------------------------
'Выведем сообщение о выполненной работе
   MsgBox "Чертёж подготовлен для вставки в Word", vbInformation, gstrНазваниеПрограммы
   Exit Sub
ОбработкаОшибок:
   MsgBox "При подготовке чертежа для Word произошла ошибка!" & vbLf & vbLf & _
          "Название ошибки: " & Err.Description & vbLf & vbLf & _
          "Номер ошибки = " & Err.Number, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

[Vova]

*^C^C-ATTEDIT;;;;;\;C;15;;
Здесь цвет # 15. Поставь свой и щелкай по атрибутам

[МишаИнженер]

Спасибо TararykovDG! Всё работает

[Unfamous]

Сообщение от Vova *^C^C-ATTEDIT;;;;;\;C;15;; Здесь цвет # 15. Поставь свой и щелкай по атрибутам

А как будет выглядеть макрос с возможностью выбора цвета и выбора пачки блоков?

К примеру нажал кнопку, выделил нужное количество блоков, выбрал цвет. Такое возможно?

[Vova]

Сообщение от Unfamous Такое возможно?

http://forum.dwg.ru/showthread.php?t...ghlight=BGCATT