Добавление выделенных объектов в блок

Миша

Миша
Восстановленный участник

На форуме с 31 декабря 2001г.
Сообщений: 322
Спасибо: 0

Тема: Добавление выделенных объектов в блок

Помогите доделать программу:

Private Sub CommandButton15_ДобавитьВыделенныеОбъектыВБлок_Click()
Dim lngНомОбъекта As Long, acobjОбъектЧертежа As acadObject, lngКолвоОбъектов As Long
Dim selsetНаборОбъектов As AcadSelectionSet, acobjСсылкаНаБлок As AcadBlockReference
Dim removeObject(0 To 0) As AcadEntity
On Error GoTo ОбработкаОшибок
   If ПризнакНаличияЭлементаВКоллекции("ОБЪЕКТЫДОБАВЛЯЕМЫЕВБЛОК", ThisDrawing.SelectionSets, 2) Then
      ThisDrawing.SelectionSets("ОБЪЕКТЫДОБАВЛЯЕМЫЕВБЛОК").Delete
   End If
   Set selsetНаборОбъектов = ThisDrawing.SelectionSets.Add("ОБЪЕКТЫДОБАВЛЯЕМЫЕВБЛОК")
   Me.Hide
   selsetНаборОбъектов.SelectOnScreen
ВыделитьБлок:
   ThisDrawing.Utility.GetEntity acobjСсылкаНаБлок, vBasePoint, "Выдели блок в который надо добавить объекты:"
   If Not TypeOf acobjСсылкаНаБлок Is AcadBlockReference Then
      glngОтвет = MsgBox("Продолжать выделять блок?", vbInformation, gstrНазваниеПрограммы)
      If glngОтвет = vbNo Then
         Me.Show
      ElseIf glngОтвет = vbCancel Then
         End
      End If
      GoTo ВыделитьБлок
   End If
'Проверим не находится ли выделеный блок среди выделеных объектов ранее
   For lngНомОбъекта = 0 To selsetНаборОбъектов.Count - 1
      Set acobjОбъектЧертежа = selsetНаборОбъектов(lngНомОбъекта)
      If TypeOf acobjОбъектЧертежа Is AcadBlockReference Then
         If acobjОбъектЧертежа.Name = acobjСсылкаНаБлок.Name Then
            Set removeObject(0) = acobjОбъектЧертежа
            selsetНаборОбъектов.RemoveItems removeObject
            lngНомОбъекта = lngНомОбъекта - 1
         End If
      End If
      lngНомОбъекта = lngНомОбъекта + 1
   Next lngНомОбъекта
'Добавим отфильтрованные выделенные объекты в блок
   ThisDrawing.Blocks(acobjСсылкаНаБлок.Name).AddItems selsetНаборОбъектов
'Удалим выделеные объекты
   lngКолвоОбъектов = selsetНаборОбъектов.Count
   selsetНаборОбъектов.Erase
   selsetНаборОбъектов.Delete
   acobjСсылкаНаБлок.Update
   MsgBox "В блок """ & acobjСсылкаНаБлок.Name & " добавлено " & lngКолвоОбъектов & " объектов.", vbInformation, gstrНазваниеПрограммы
   Me.Show
'Здесь нужно использовать метод CopyObjects, но сначала надо преобразовать набор в массив объектов
'Что-то вроде:
'Dim varObjects() As Object
'ThisDrawing.CopyObjects(varObjects, ThisDrawing.Blocks (acobjСсылкаНаБлок.Name))
ОбработкаОшибок:
   MsgBox "При добавлении объектов в блок произошла ошибка:" & vbLf & _
         "номер = " & Err.Number & vbLf & _
         "с описанием: " & Err.Description, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

Миша

Миша
Восстановленный участник

На форуме с 31 декабря 2001г.
Сообщений: 322
Спасибо: 0

Re: Добавление выделенных объектов в блок

Подскажите кто знает!
Существуют ли методы AddItems или AddItem для добавления объектов в блок на языках VLisp или ObjectARX. Мне совсем не хочется писать программу добавления каждого объекта чертежа персональным образом. Хочется чтобы всё это выглядело наподобии метода AcadSelectionSet.AddItems.
Если справиться с этой проблемой, то можно написать программу вставки блоков с обновлением блоков. Помогите кто может!

kpblc

kpblc
Активный участник

Откуда: С.-Петербург
На форуме с 29 ноября 2004г.
Сообщений: 8,348
Спасибо: 24

Re: Добавление выделенных объектов в блок

> Миша
Да. Рисуй в пространтво блока

Миша

Миша
Восстановленный участник

На форуме с 31 декабря 2001г.
Сообщений: 322
Спасибо: 0

Re: Добавление выделенных объектов в блок

Рисовать я понимаю надо методами:

acobjБлок.AddLine
acobjБлок.AddArc
acobjБлок.AddPolyline и т.д.

А как быть с размерами, первоначальный вид которых после тщательной ручной настройки я считаю невозможно восстановить програмными средствами VBA. Как например дать команду переместить текст в определёную точку да ещё с указательной линией? Для меня проблема сначала просто определить у имеющегося размера координаты этой точки, а потом уже пытаться переместить в эту точку текст копии размера в блоке.
Уважаемый kpblc! Я понял, что Вы Lispовик и хочу у Вас спросить: есть ли на Lispe команда добавления в блок целого набора объектов всех вместе и сразу, а не по одному, как это сделали в VBA?
Например для объекта SelectionSet есть метод:

acobjSelSet.AddItems(vМассивОбъектовЧертежа)

Больше метода AddItems нет ни у одного объекта в VBA! Почему спрашивается не сделали такой метод для объекта AcadBlock? Неужели авторы VBA хотели чтобы программисты сами писали функцию AddItems с персональными настройками и ухищрениями для каждого имеющегося объекта чертежа. Обычному программисту это сделать невозможно, к тому же код этой функции займёт очень много места в программе и будет требовать много памяти.
Если кто может поделитесь опытом написания функции AddItems для AcadBlock!
Хотелось бы узнать может такая команда есть на языке ObjectARX?

kpblc

kpblc
Активный участник

Откуда: С.-Петербург
На форуме с 29 ноября 2004г.
Сообщений: 8,348
Спасибо: 24

Re: Добавление выделенных объектов в блок

Насчет набора, по-моему, невозможно - только перечисление объектов (список, пользуясь лисповой терминологией). Только если использовать метод CopyObjects, но и он не без тонкостей - в частности, критичное значение имеет точка вставки блока; работать можно только с описаниями блока, на вставки метод выдает, по-моему, ошибки. Изменение точки вставки блока перемещает уже отрисованные примитивы в новую точку, а атрибуты остаются на месте; новые примитивы рисуются относительно существующей точки вставки и проч.
В общем, метод, по-моему, сделан по принципу "лучше, чем ничего".
Насчет размеров. Сами размеры сделать и перенастроить можно, это-то не особо проблема, я думаю. Вот создать или изменить размерный стиль только средствами VBA и ActiveX мне не удалось.
Теперь насчет AddItems. Если посмотреть на методы рисования как такового, то можно вычислить, что как таковое рисование все равно выполняется в блок (потому как *model_space* и *paper_space* пространства можно представить как блоки, мало того, они и опознаются предыдущими версиями ACAD'a как блоки с такими именами). Так что если вместо указателя пространства подставить указатель на блок, методы будут точно такими же.

Миша

Миша
Восстановленный участник

На форуме с 31 декабря 2001г.
Сообщений: 322
Спасибо: 0

Re: Добавление выделенных объектов в блок

Насчёт размерных стилей у меня проблем нет. Вот например команда создания размерного стиля:

Dim НовыйСтильРазмеров As AcadDimStyle
      НазваниеСтиля = InputBox("Введи название создаваемого стиля размеров:", "Редактирование стилей", "STANDARD")
      If НазваниеСтиля = "" Then
         Exit Sub
      End If
      ListBox2_СписокСтилейРазмеров.TextColumn = 2
      НазвСтиляШаблона = ListBox2_СписокСтилейРазмеров.Text
      Set НовыйСтильРазмеров = ThisDrawing.DimStyles.Add(НазваниеСтиля)
      НовыйСтильРазмеров.CopyFrom ThisDrawing.DimStyles(НазвСтиляШаблона)

А вот команда стандартизации существующего размерного стиля:

Private Sub CommandButton1_СтандартизироватьРазмерныйСтиль_Click()
   intНомерСтиляРазмеров = ListBox2_СписокСтилейРазмеров.ListIndex
   If intНомерСтиляРазмеров < 0 Then intНомерСтиляРазмеров = 0
'=====Размерные линии=====
'1. Цвет-DIMCLRD='ByLayer'=256
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCLRD", "256", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'2. Толщина линии-DIMLWD='ByLayer'=-1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLWD", "-1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'3. Расстояние до метки-DIMDLE=0.9
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMDLE", "0,9", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'4. Базовое расстояние-DIMDLI=3.5
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMDLI", "3,5", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'Включить размерные линии DIMSD1, DIMSD2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Граничные линии=====
'5. Цвет-DIMCLRE='ByLayer'=256
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCLRE", "256", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'6. Толщина линии-DIMLWE='ByLayer'=-1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLWE", "-1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'7. Расстояние до линии-DIMEXE=0.9
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMEXE", "0,9", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'8. Смещение от начала-DIMEXO=0.625
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMEXO", "0,625", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'Включить граничные линии DIMSE1, DIMSE2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Стрелки=====
'9а. DIMSAH="1"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSAH", 1, ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'9. 1-ая-DIMBLK1="_OBLIQUE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK1", "OBLIQUE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'10. 2-ая-DIMBLK2="_OBLIQUE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK2", "OBLIQUE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'11. Указатель-DIMLDRBLK="_NONE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLDRBLK", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'12. Размер стрелки-DIMASZ=1.25
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMASZ", "1,25", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Центральный маркер для окружности=====
'13, 14. Маркер и размеры-DIMCEN=1.25
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCEN", "1,25", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Отображение текста=====
'15. Стиль текста-DIMTXSTY="STANDARD"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTXSTY", "STANDARD", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'16. Цвет текста-DIMCLRT=6
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMCLRT", "6", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'17. Высота текста-DIMTXT=2.5
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTXT", "2,5", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Размещение текста=====
'18. Вертикальное-DIMTAD='Above'=1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTAD", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'19. Горизонтальное-DIMJUST='Centered'=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMJUST", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'20. Расстояние до текста-DIMGAP=0.9
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMGAP", "0,9", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Выравнивание текста=====
'21. Выравнивание всех размеров кроме ординатных (между размерными линиями)-DIMTIH="OFF"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTIH", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'22. Выравнивание всех размеров кроме ординатных (за размерными линиями)-DIMTOH="OFF"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOH", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Опции подгонки=====
'23. DIMFIT=3
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMFIT", "3", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'24. DIMSOXD="OFF"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSOXD", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Размещение текста=====
'25. DIMTMOVE=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTMOVE", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Масштаб размеров=====
'26. Масштаб линий и элементов размеров-DIMSCALE
'   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSCALE", 1, ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Настройка=====
'27. Размещение текста вручную-DIMUPT="OFF"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMUPT", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'28. Всегда рисовать размерную линию-DIMTOFL="ON"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOFL", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Линейные измерения=====
'29. Формат единиц-DIMLUNIT='Decimal'=2
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLUNIT", "2", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'30. Точность-DIMDEC=4
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMDEC", "4", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'31. Десятичный разделитель-DIMDSEP="."
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMDSEP", ".", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'32. Округление-DIMRND=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMRND", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'33. Префикс, суффикс-DIMPOST=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMPOST", ".", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'34. Коэффициент масштаба-DIMLFAC=1
'   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLFAC", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'35. Отображение нуля-DIMZIN=8
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMZIN", "8", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Угловые измерения=====
'36. Формат единиц-DIMAUNIT='Decimal'=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMAUNIT", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'37. Точность-DIMADEC=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMADEC", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'38. Отображение нуля-DIMAZIN=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMAZIN", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Альтернативные единицы=====
'39. Отображение альтернативных единиц-DIMALT=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMALT", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Допуски=====
'40. Отключить отображение допусков DIMTOL=0 или DIMLIM=1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOL", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'Обновить список с параметрами стилей размеров
   Call ЗаполнитьСписокПараметровСтилейРазмеров
'Вывести отчёт
   MsgBox "Параметры размерного стиля: """ & ThisDrawing.DimStyles(intНомерСтиляРазмеров).Name & """ приведены к общему стандарту.", vbInformation, gstrНазваниеПрограммы
End Sub
Sub УстановитьСвойствоПараметраРазмерногоСтиля(НазвСистПерем As String, ВелСистПерем As String, _
   СтильРазмера As AcadDimStyle)
Dim acobjАктивныйСтильРазмеров As AcadDimStyle
On Error GoTo ОбработкаОшибок
'Запомнить активный стиль размеров
   Set acobjАктивныйСтильРазмеров = ThisDrawing.ActiveDimStyle
   ThisDrawing.ActiveDimStyle = СтильРазмера
   If VBA.IsNumeric(ВелСистПерем) Then
      If ВелСистПерем = 256 Then
         ThisDrawing.SetVariable НазвСистПерем, acByLayer
      ElseIf ВелСистПерем = -1 Then
         ThisDrawing.SetVariable НазвСистПерем, acLnWtByLayer
      Else
         ThisDrawing.SetVariable НазвСистПерем, VBA.CDbl(ВелСистПерем)
      End If
   Else
      ThisDrawing.SetVariable НазвСистПерем, ВелСистПерем
   End If
   ThisDrawing.ActiveDimStyle.CopyFrom ThisDrawing.Application.ActiveDocument
'Восстановить активный стиль размеров
   ThisDrawing.ActiveDimStyle = acobjАктивныйСтильРазмеров
   Exit Sub
ОбработкаОшибок:
   MsgBox "Произошла ошибка при установке свойства размерного стиля: """ & СтильРазмера.Name & """," & vbLf & _
          "Название системной переменной: """ & НазвСистПерем & """," & vbLf & _
          "Величина параметра: """ & ВелСистПерем & """," & vbLf & vbLf & _
          "Номер ошибки = " & Err.Number & vbLf & vbLf & _
          "Название ошибки: " & Err.Description, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

Работает как часы, накаких проблем. А на счёт CopyObjects можно поподробнее, неужели нельзя указать новую точку вставки? Что такое "описания блока", это наверное объекты чертежа из которых состоит блок. Если можно приведите пример кода пожалуйста!

kpblc

kpblc
Активный участник

Откуда: С.-Петербург
На форуме с 29 ноября 2004г.
Сообщений: 8,348
Спасибо: 24

Re: Добавление выделенных объектов в блок

> Миша
Ну а как сделать "подстили"? Т.е. для линейных и повернутых размеров один, для угловых - другой, для диаметров - третий и т.д.? У меня просто не получилось сделать только ActiveX (читай - VBA), пришлось ковыряться с DXF-группами. Ну да ладно, это лирика.
Насчет описаний блоков. Я, к сожалению, в VBA как известное животное в не менее известных фруктах. Поэтому попробую объяснить "на пальцах", без кода. Суть в следующем. Есть вставки блоков, с именем AcDbBlockReference* - имеют точку масштабы по осям, угол поворота, точку вставки и прочие атрибуты обычных примитивов. Но базируются они на описании блока - имя у него уже AcDbBlockTableRecord. Вот у второго (описания) есть уже такие свойства, как Count - количество входящих примитивов и Origin - базовая точка блока.
Добавление примитивов в блок производится именно для AcDbBlockTableRecord. И CopyObjects работает именно с ним. Так вот, для ради интересу можно сделать, например, следующее (я попробую показать вариант для VBA, но без проверок, так что сильно прошу не бить ногами в прыжках):
1. Добавляем новое описание блока:
- Определяем базовую точку нового блока:

Dim blkNewBlockInsPoint(2) As Double
  blkNewBlockInsPoint(0) = 0: blkNewBlockInsPoint(1) = 0: blkNewBlockInsPoint(2) = 0

- добавляем описание блока:

Set blkNewBlock = ThisDrawing.Blocks.Add(blkNewBlockInsPoint, "test block")

Если сейчас посмотреть DesignCenter, то там будет пустой блок с именем test block
2. Создаем 2 окружности:

centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
    radius1 = 5#: radius2 = 7#
    radius1Copy = 1#: radius2Copy = 2#
Set circleObj1 = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius1)
    Set circleObj2 = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius2

3. И копируем их:

retVal = ThisDrawing.CopyObjects(objCollection, blkNewBlock)

По-моему, так.
И вот теперь самое грустное - если в списке objCollection будут атрибуты (и, по-моему, тексты), то у них при вставке может слететь точка вставки, т.е. они будут копироваться в базовую точку блока. Придется вычислять разницу, и учитывать его. А если еще и учесть, то при изменении выравнивания пляшут точки вставки (InsertionPoint) и точки выравнивания (TextAlignmentPoint), то тут становится немного страшно :).
Интересно, я хоть на тот вопрос отвечал?
---
*) Имена получены через лисп, дампом объектов

Миша

Миша
Восстановленный участник

На форуме с 31 декабря 2001г.
Сообщений: 322
Спасибо: 0

Re: Добавление выделенных объектов в блок

> kpblc
С подстилями я не работаю. Если надо специальный стиль то создаю его как обычный стиль добавляя суффикс через чёрточку. Вот например команды создания специальных стилей с которыми я работаю:

Private Sub ComBtn_СоздатьСтильРазмеров_hid_Click()
Dim acobjАктивныйСтильРазмеров As AcadDimStyle, strНазваниеАктивногоСтиляРазмеров As String
Dim strНазваниеНовогоСтиляРазмеров As String, acobjНовыйСтильРазмеров As AcadDimStyle
Dim blnПризнакНаличияСтиля As Boolean
   Set acobjАктивныйСтильРазмеров = ThisDrawing.ActiveDimStyle
   strНазваниеАктивногоСтиляРазмеров = acobjАктивныйСтильРазмеров.Name
   If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 4)) = "_HID" Then
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеАктивногоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      GoSub ОбновитьПараметрыСтиля
      MsgBox "Активный стиль размеров является стилем ""_hid"", поэтому были обновлены параметры этого стиля", vbInformation, gstrНазваниеПрограммы
   Else
      If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 4)) = "_RADIUS" Then
         strНазваниеНовогоСтиляРазмеров = Left(strНазваниеАктивногоСтиляРазмеров, Len(strНазваниеАктивногоСтиляРазмеров) - 7) & "_hid"
      Else
         strНазваниеНовогоСтиляРазмеров = strНазваниеАктивногоСтиляРазмеров & "_hid"
      End If
'Проверить не имеется ли в наличии стиль с таким названием и заодно определить его номер
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеНовогоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      If intНомерСтиляРазмеров = -1 Then
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles.Add(strНазваниеНовогоСтиляРазмеров)
         acobjНовыйСтильРазмеров.CopyFrom ThisDrawing.DimStyles(strНазваниеАктивногоСтиляРазмеров)
         intНомерСтиляРазмеров = ThisDrawing.DimStyles.Count - 1
      Else
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles(intНомерСтиляРазмеров)
         blnПризнакНаличияСтиля = True
      End If
      GoSub ОбновитьПараметрыСтиля
      Call ЗаполнитьСписокПараметровСтилейРазмеров
      If Me.MultiPage1_СтилиЧертежа.Pages(5).ToggleButton1_ДелатьСоздаваемыеСлоиИСтилиАктивными Then
         ThisDrawing.ActiveDimStyle = acobjНовыйСтильРазмеров
         ComboBox5_АктивныйСтильРазмеров.ListIndex = intНомерСтиляРазмеров
      End If
      If blnПризнакНаличияСтиля = False Then
         MsgBox "Создан новый стиль размеров: """ & strНазваниеНовогоСтиляРазмеров & """" & vbLf & _
                "на основе стиля размеров: """ & strНазваниеАктивногоСтиляРазмеров & """.", vbInformation, gstrНазваниеПрограммы
      Else
         MsgBox "В чертеже уже имеется стиль: """ & strНазваниеНовогоСтиляРазмеров & """ поэтому были обновлены его параметры", vbInformation, gstrНазваниеПрограммы
      End If
   End If
   Exit Sub
ОбновитьПараметрыСтиля:
'=====Размерные линии=====
'Отключить размерные линии DIMSD1, DIMSD2=1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD1", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD2", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Граничные линии=====
'Отключить граничные линии DIMSE1, DIMSE2=1
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE1", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE2", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Стрелки=====
'9а. DIMSAH="1"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSAH", 1, ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'9. 1-ая-DIMBLK1=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK1", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'10. 2-ая-DIMBLK2=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK2", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'11. Указатель-DIMLDRBLK=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLDRBLK", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Настройка=====
'Отменить рисование размерной линию-DIMTOFL="OFF"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOFL", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Return
End Sub
Private Sub ComBtn_СоздатьСтильРазмеров_Radius_Click()
Dim acobjАктивныйСтильРазмеров As AcadDimStyle, strНазваниеАктивногоСтиляРазмеров As String
Dim strНазваниеНовогоСтиляРазмеров As String, acobjНовыйСтильРазмеров As AcadDimStyle
Dim blnПризнакНаличияСтиля As Boolean
   Set acobjАктивныйСтильРазмеров = ThisDrawing.ActiveDimStyle
   strНазваниеАктивногоСтиляРазмеров = acobjАктивныйСтильРазмеров.Name
   If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 7)) = "_RADIUS" Then
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеАктивногоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      GoSub ОбновитьПараметрыСтиля
      MsgBox "Активный стиль размеров является стилем ""_Radius"", поэтому были обновлены параметры этого стиля", vbInformation, gstrНазваниеПрограммы
   Else
      If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 4)) = "_HID" Then
         strНазваниеНовогоСтиляРазмеров = Left(strНазваниеАктивногоСтиляРазмеров, Len(strНазваниеАктивногоСтиляРазмеров) - 4) & "_Radius"
      ElseIf UCase(Right(strНазваниеАктивногоСтиляРазмеров, 5)) = "_УГЛЫ" Then
         strНазваниеНовогоСтиляРазмеров = Left(strНазваниеАктивногоСтиляРазмеров, Len(strНазваниеАктивногоСтиляРазмеров) - 5) & "_Radius"
      Else
         strНазваниеНовогоСтиляРазмеров = strНазваниеАктивногоСтиляРазмеров & "_Radius"
      End If
'Проверить не имеется ли в наличии стиль с таким названием и заодно определить его номер
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеНовогоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      If intНомерСтиляРазмеров = -1 Then
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles.Add(strНазваниеНовогоСтиляРазмеров)
         acobjНовыйСтильРазмеров.CopyFrom ThisDrawing.DimStyles(strНазваниеАктивногоСтиляРазмеров)
         intНомерСтиляРазмеров = ThisDrawing.DimStyles.Count - 1
      Else
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles(intНомерСтиляРазмеров)
         blnПризнакНаличияСтиля = True
      End If
      GoSub ОбновитьПараметрыСтиля
      Call ЗаполнитьСписокПараметровСтилейРазмеров
      If Me.MultiPage1_СтилиЧертежа.Pages(5).ToggleButton1_ДелатьСоздаваемыеСлоиИСтилиАктивными Then
         ThisDrawing.ActiveDimStyle = acobjНовыйСтильРазмеров
         ComboBox5_АктивныйСтильРазмеров.ListIndex = intНомерСтиляРазмеров
      End If
      If blnПризнакНаличияСтиля = False Then
         MsgBox "Создан новый стиль размеров: """ & strНазваниеНовогоСтиляРазмеров & """" & vbLf & _
                "на основе стиля размеров: """ & strНазваниеАктивногоСтиляРазмеров & """.", vbInformation, gstrНазваниеПрограммы
      Else
         MsgBox "В чертеже уже имеется стиль: """ & strНазваниеНовогоСтиляРазмеров & """ поэтому были обновлены его параметры", vbInformation, gstrНазваниеПрограммы
      End If
   End If
   Exit Sub
ОбновитьПараметрыСтиля:
'=====Размерные линии=====
'Включить размерные линии DIMSD1, DIMSD2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Граничные линии=====
'Включить граничные линии DIMSE1, DIMSE2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Стрелки=====
'9а. DIMSAH="1"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSAH", 1, ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'9. 1-ая-DIMBLK1=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK1", ".", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'10. 2-ая-DIMBLK2=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK2", ".", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'11. Указатель-DIMLDRBLK=""
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLDRBLK", ".", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'12. Размер стрелки-DIMASZ=1.25
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMASZ", "1,25", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Настройка=====
'Назначить рисование размерной линию-DIMTOFL="ON"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOFL", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Return
End Sub
Private Sub ComBtn_СоздатьСтильРазмеров_Углы_Click()
Dim acobjАктивныйСтильРазмеров As AcadDimStyle, strНазваниеАктивногоСтиляРазмеров As String
Dim strНазваниеНовогоСтиляРазмеров As String, acobjНовыйСтильРазмеров As AcadDimStyle
Dim blnПризнакНаличияСтиля As Boolean
   Set acobjАктивныйСтильРазмеров = ThisDrawing.ActiveDimStyle
   strНазваниеАктивногоСтиляРазмеров = acobjАктивныйСтильРазмеров.Name
   If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 5)) = "_УГЛЫ" Then
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеАктивногоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      GoSub ОбновитьПараметрыСтиля
      MsgBox "Активный стиль размеров является стилем ""_Углы"", поэтому были обновлены параметры этого стиля", vbInformation, gstrНазваниеПрограммы
   Else
      If UCase(Right(strНазваниеАктивногоСтиляРазмеров, 4)) = "_HID" Then
         strНазваниеНовогоСтиляРазмеров = Left(strНазваниеАктивногоСтиляРазмеров, Len(strНазваниеАктивногоСтиляРазмеров) - 4) & "_Углы"
      ElseIf UCase(Right(strНазваниеАктивногоСтиляРазмеров, 7)) = "_RADIUS" Then
         strНазваниеНовогоСтиляРазмеров = Left(strНазваниеАктивногоСтиляРазмеров, Len(strНазваниеАктивногоСтиляРазмеров) - 7) & "_Углы"
      Else
         strНазваниеНовогоСтиляРазмеров = strНазваниеАктивногоСтиляРазмеров & "_Углы"
      End If
'Проверить не имеется ли в наличии стиль с таким названием и заодно определить его номер
      intНомерСтиляРазмеров = НомерЭлементаВКоллекции(strНазваниеНовогоСтиляРазмеров, ThisDrawing.DimStyles, 2)
      If intНомерСтиляРазмеров = -1 Then
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles.Add(strНазваниеНовогоСтиляРазмеров)
         acobjНовыйСтильРазмеров.CopyFrom ThisDrawing.DimStyles(strНазваниеАктивногоСтиляРазмеров)
         intНомерСтиляРазмеров = ThisDrawing.DimStyles.Count - 1
      Else
         Set acobjНовыйСтильРазмеров = ThisDrawing.DimStyles(intНомерСтиляРазмеров)
         blnПризнакНаличияСтиля = True
      End If
      GoSub ОбновитьПараметрыСтиля
      Call ЗаполнитьСписокПараметровСтилейРазмеров
      If Me.MultiPage1_СтилиЧертежа.Pages(5).ToggleButton1_ДелатьСоздаваемыеСлоиИСтилиАктивными Then
         ThisDrawing.ActiveDimStyle = acobjНовыйСтильРазмеров
         ComboBox5_АктивныйСтильРазмеров.ListIndex = intНомерСтиляРазмеров
      End If
      If blnПризнакНаличияСтиля = False Then
         MsgBox "Создан новый стиль размеров: """ & strНазваниеНовогоСтиляРазмеров & """" & vbLf & _
                "на основе стиля размеров: """ & strНазваниеАктивногоСтиляРазмеров & """.", vbInformation, gstrНазваниеПрограммы
      Else
         MsgBox "В чертеже уже имеется стиль: """ & strНазваниеНовогоСтиляРазмеров & """ поэтому были обновлены его параметры", vbInformation, gstrНазваниеПрограммы
      End If
   End If
   Exit Sub
ОбновитьПараметрыСтиля:
'=====Размерные линии=====
'Включить размерные линии DIMSD1, DIMSD2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSD2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Граничные линии=====
'Включить граничные линии DIMSE1, DIMSE2=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE1", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSE2", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Стрелки=====
'9а. DIMSAH="1"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMSAH", 1, ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'9. 1-ая-DIMBLK1="_NONE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK1", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'10. 2-ая-DIMBLK2="_NONE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMBLK2", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'11. Указатель-DIMLDRBLK="_NONE"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMLDRBLK", "NONE", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'12. Размер стрелки-DIMASZ=1.25
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMASZ", "1,25", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Настройка=====
'Назначить рисование размерной линию-DIMTOFL="ON"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOFL", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Выравнивание текста=====
'21. Выравнивание всех размеров кроме ординатных (между размерными линиями)-DIMTIH="ON"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTIH", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'22. Выравнивание всех размеров кроме ординатных (за размерными линиями)-DIMTOH="ON"
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMTOH", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'=====Угловые измерения=====
'36. Формат единиц-DIMAUNIT='Decimal'=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMAUNIT", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'37. Точность-DIMADEC=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMADEC", "1", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
'38. Отображение нуля-DIMAZIN=0
   Call УстановитьСвойствоПараметраРазмерногоСтиля("DIMAZIN", "0", ThisDrawing.DimStyles(intНомерСтиляРазмеров))
   Return
End Sub

Извини, дальше отвечать на вопрос нету времени, отвечу потом.

Добавление выделенных объектов в блок

Сообщения 8

#1 Тема от Миша 24 мая 2006г. 20:59:21

Тема: Добавление выделенных объектов в блок

#2 Ответ от Миша 26 мая 2006г. 18:25:57

Re: Добавление выделенных объектов в блок

#3 Ответ от kpblc 29 мая 2006г. 09:50:44

Re: Добавление выделенных объектов в блок

#4 Ответ от Миша 30 мая 2006г. 20:35:38

Re: Добавление выделенных объектов в блок

#5 Ответ от kpblc 31 мая 2006г. 09:10:48

Re: Добавление выделенных объектов в блок

#6 Ответ от Миша 31 мая 2006г. 20:13:15

Re: Добавление выделенных объектов в блок

#7 Ответ от kpblc 1 июня 2006г. 08:47:37

Re: Добавление выделенных объектов в блок

#8 Ответ от Миша 2 июня 2006г. 01:52:31

Re: Добавление выделенных объектов в блок

Сообщения 8

Тему читают: 1 гость

Вход на форум «Форумы CADUser»x

Ссылки