Как сделать так чтобы в AutoCAD2012 появилась эта функция?

МишаИнженер · 08.01.2011, 11:10

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

Код:

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

Public Sub НазначитьСлойЦветИСтиль()
Dim objВыделенныйОбъект As ACADObject, vP As Variant
On Error Resume Next
ВыделитьОбъект:
   ThisDrawing.Utility.GetEntity objВыделенныйОбъект, vP, "Выдели объект:"
   If Err.Number <> 0 Then
      glngОтвет = MsgBox("Повторить выбор объекта?", vbYesNo, gstrНазваниеПрограммы)
      If glngОтвет = vbNo Then End
      Err.Clear
      GoTo ВыделитьОбъект
   End If
   ThisDrawing.ActiveLayer = ThisDrawing.Layers(objВыделенныйОбъект.Layer)
   ThisDrawing.SetVariable "CECOLOR", CStr(objВыделенныйОбъект.color)
   If InStr(1, UCase(objВыделенныйОбъект.ObjectName), "POLYLINE") > 0 Then
      ThisDrawing.SetVariable "PLINEWID", objВыделенныйОбъект.ConstantWidth
   Else
      ThisDrawing.SetVariable "PLINEWID", 0
   End If
   If InStr(1, UCase(objВыделенныйОбъект.ObjectName), "LINE") > 0 Or _
      InStr(1, UCase(objВыделенныйОбъект.ObjectName), "ARC") > 0 Or _
      InStr(1, UCase(objВыделенныйОбъект.ObjectName), "CIRCLE") > 0 Then
      ThisDrawing.SetVariable "CELTSCALE", objВыделенныйОбъект.LinetypeScale
      ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes(objВыделенныйОбъект.Linetype)
   Else
      ThisDrawing.SetVariable "CELTSCALE", 1
      ThisDrawing.SetVariable "CELTYPE", "BYLAYER"
   End If
   If InStr(1, UCase(objВыделенныйОбъект.ObjectName), "HATCH") > 0 Then
      ThisDrawing.SetVariable "HPNAME", objВыделенныйОбъект.patternName
      ThisDrawing.SetVariable "HPSCALE", objВыделенныйОбъект.PatternScale
      ThisDrawing.SetVariable "HPANG", objВыделенныйОбъект.PatternAngle
      ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes(objВыделенныйОбъект.Linetype)
      ThisDrawing.SetVariable "CELTSCALE", objВыделенныйОбъект.LinetypeScale
      vP = objВыделенныйОбъект.Origin
      ThisDrawing.SetVariable "HPORIGIN", vP
   ElseIf InStr(1, UCase(objВыделенныйОбъект.ObjectName), "MLINE") > 0 Then
      ThisDrawing.SetVariable "CMLSTYLE", objВыделенныйОбъект.StyleName
      ThisDrawing.SetVariable "CMLSCALE", objВыделенныйОбъект.MLineScale
      ThisDrawing.SetVariable "CMLJUST", objВыделенныйОбъект.Justification
   ElseIf InStr(1, UCase(objВыделенныйОбъект.ObjectName), "DIM") > 0 Then
      ThisDrawing.ActiveDimStyle = ThisDrawing.DimStyles(objВыделенныйОбъект.StyleName)
      If InStr(1, objВыделенныйОбъект.StyleName, "Штамп") = 0 Then
'Проверим имеется ли в чертеже слой "Размеры"
         If НаличиеСлоя("Размеры") = False Then Call СоздатьСлой("Размеры")
         If ThisDrawing.Layers("Размеры").LayerOn = True And ThisDrawing.Layers("Размеры").Freeze = False Then ThisDrawing.ActiveLayer = ThisDrawing.Layers("Размеры")
      Else
         ThisDrawing.ActiveLayer = ThisDrawing.Layers("Defpoints")
      End If
   ElseIf InStr(1, UCase(objВыделенныйОбъект.ObjectName), "TEXT") > 0 Then
      ThisDrawing.ActiveTextStyle = ThisDrawing.TextStyles(objВыделенныйОбъект.StyleName)
   End If
   Exit Sub
ОбработкаОшибок:
   MsgBox "Ошибка при назначении слоя цвета и стиля!" & vbLf & vbLf & _
          "Номер ошибки = " & Err.Number & vbLf & vbLf & _
          "Название ошибки: " & Err.Description, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

Очень надоедает искать нужный тип стиля размера в списке размеров, нужный слой, цвет и т.д. А с помощью моей функции это всё делается "за один клик мыши", а если быть точным то за два: нажать кнопку на панели задач и выбрать объект на экране. Эта функция такая удобная, что я придумал даже красочный значок к этой функции! Посмотрите прикреплённый файл:

Чтобы работала эта функция необходимо ещё две функции:

Код:

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

Public Function НаличиеСлоя(НазваниеСлоя As String) As Boolean
Dim NumObject As Long, CountObject As Long
On Error GoTo ОбработкаОшибок
'1. Проверить: имеется ли слой c заданным названием
   НаличиеСлоя = False
   CountObject = ThisDrawing.Layers.Count
   For NumObject = 1 To CountObject
      If ThisDrawing.Layers(NumObject - 1).Name = НазваниеСлоя Then
'2. Если да, то вывести соответствующий ответ и завершить функцию
         НаличиеСлоя = True
         Exit Function
      End If
   Next NumObject
'3. Если слой не найден, то вывести соответствующий ответ и завершить функцию
   Exit Function
ОбработкаОшибок:
   MsgBox "При проверке наличия слоя """" & НазваниеСлоя & """" произошла ошибка:" & vbLf & vbLf & _
          "номер = " & Err.Number & vbLf & vbLf & _
          "с описанием: " & Err.Description, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Function

Public Sub СоздатьСлой(НазваниеСлоя As String, Optional ЦветСлоя As Variant, Optional СтильЛинийСлоя As String, Optional НазваниеФайлаТиповЛиний As String)
Dim layerObj As AcadLayer, lngНомСтиля As Long
On Error GoTo ОбработкаОшибок
' Add the layer to the layers collection
   Set layerObj = ThisDrawing.Layers.Add(НазваниеСлоя)
   If Not IsMissing(ЦветСлоя) Then
      layerObj.color = ЦветСлоя
   End If
   If СтильЛинийСлоя <> "" Then
   'Получим параметры стилей
      For lngНомСтиля = 1 To ThisDrawing.Linetypes.Count
         If ThisDrawing.Linetypes.Item(lngНомСтиля - 1).Name = СтильЛинийСлоя Then
            GoTo НазначитьСтильЛинии
         End If
      Next lngНомСтиля
      ThisDrawing.Linetypes.Load СтильЛинийСлоя, НазваниеФайлаТиповЛиний
НазначитьСтильЛинии:
      layerObj.Linetype = СтильЛинийСлоя
   End If
   ' Display the status of the new layer
   MsgBox "Добавлен слой """ & НазваниеСлоя & """.", vbInformation, gstrНазваниеПрограммы
   Exit Sub
ОбработкаОшибок:
   MsgBox "При создании нового слоя """ & НазваниеСлоя & """ произошла ошибка:" & vbLf & _
         "номер = " & Err.Number & vbLf & _
         "с описанием: " & Err.Description, vbExclamation, gstrНазваниеПрограммы
   Resume Next
End Sub

Кулик Алексей aka kpblc · 08.01.2011, 11:32

Функция называется _.matchprop, если не ошибаюсь.

Елпанов Евгений · 08.01.2011, 11:35

Пара вопросов, во первых, ты действительно тестировал функцию на 2012 акаде, если да, то какой билд? Во вторых, ты уверен, что подключил vba, точнее установил все необходимые библиотеки, нужный .NET и саму инсталляцию vba для 2012 акада?

МишаИнженер · 08.01.2011, 11:35

_.matchprop не работает!

Лиспер · 08.01.2011, 11:38

Цитата:

Сообщение от МишаИнженер

Как сделать так чтобы в AutoCAD2012 появилась эта функция?

Очень просто - написать ее.
Offtop: Я уж молчу про имена функций и переменных...

МишаИнженер · 08.01.2011, 11:40

Цитата:

Пара вопросов, во первых, ты действительно тестировал функцию на 2012 акаде, если да, то какой билд? Во вторых, ты уверен, что подключил vba, точнее установил все необходимые библиотеки, нужный .NET и саму инсталляцию vba для 2012 акада?

AutoCAD2012 версия для тестирования, завершается закачка! Проверю вечером!

Я уже написал. На чём ещё писать? На ЛИСПЕ?

Лиспер · 08.01.2011, 11:42

МишаИнженер, написал - молодца. Работает? Замечательно. Теперь загружай.
Я не понимаю, в чем вопрос-то собственно?

МишаИнженер · 08.01.2011, 11:48

При запуске макросов VBA появляется ошибка: смотрите файл.
Что-то случилось с ситемой. Переустановка AutoCAD не помогла. Наверное надо переустанавливать систему

Кулик Алексей aka kpblc · 08.01.2011, 11:54

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

МишаИнженер · 08.01.2011, 12:07

Сначала при попытке запустить панель с кнопочками начинаются появляться предупреждения что на правильно назначен тип переменных.
Затем когда виден код пытаюсь в среде VBA пытаюсь вывести форму на экран щёлкая на ней 2 раза мышкой. Форма не выводится а выводится это предупреждение. Код формы на экран выводится и некоторые другие формы выводятся. А некоторые не выводятся. А самое главное не может запуститься панель с кнопками Что делать?

Кулик Алексей aka kpblc · 08.01.2011, 13:55

Для начала - логику переделать.
1. А если пользователь решит отказаться от выполнения команды, чего ему делать?
2. А если выделен "не тот объект", что делаться должно?
3. Почему не выводится никаких сообщений о том, что и как сделано?
4. Почему тип и вес линии при условии выделения штриховки игнорируются?
5. Как будет обрабатываться вариант, если примитив размера находится на блокированном слое?
---
P.S. VBA для AutoCAD 2011 не ставил и ставить пока не собираюсь. Поэтому и выдавать решение не буду.

Елпанов Евгений · 08.01.2011, 14:45

Цитата:

Сообщение от Кулик Алексей aka kpblc

P.S. VBA для AutoCAD 2011 не ставил и ставить пока не собираюсь. Поэтому и выдавать решение не буду.

для AutoCAD 2012 vba другое и ставится отдельно, на сайте ADN все расписано...

МишаИнженер · 08.01.2011, 16:11

Включенность слоя на работу макроса не влияет. Программа получает объект и настраивает среду согласно свойствам объекта.
Лишние сообщения отключил потому что нет времени читать всякие сообщения.
В программу добавил пока то что нужно было для работы, если понадобятся другие свойства, то надо будет добавить. Так же хотел добавить возможность настраивать стиль мультилиний, но как-то времени не хватило. Потом надо будет посидеть и разобраться как это делается.

Кулик Алексей aka kpblc · 08.01.2011, 17:47

МишаИнженер, я говорю не о включенности, а о заблокированности слоя!

МишаИнженер · 11.01.2011, 05:08

Если объект можн выделить то программа должна работать

Лиспер · 11.01.2011, 08:08

МишаИнженер, ты все еще путаешь блокированный слой и замороженный...

МишаИнженер · 12.01.2011, 13:27

На замороженном слое объекты нельзя выделить, потому-что они не видны. Программа значит работать не будет. Разморозьте слой, в чём проблема?

Лиспер · 12.01.2011, 13:33

Йокэлэмэне... ЗАБЛОКИРУЙ слой, ЗАБЛОКИРУЙ!!!

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
сделать так, чтобы эта же команда вызывалась другой буквой	Venya	AutoCAD	2	02.11.2006 01:42
Как сделать так, чтобы ЛИСПы не надо было перезагружать?	bimari	LISP	13	24.10.2006 10:41
Возможно-ли сделать так, чтобы при щелчке по какому-либо эле	Alexyanch	AutoCAD	7	09.04.2006 18:53
как сделать, чтобы новый лисп- автоматом ставился у всех?	Соня	LISP	17	12.08.2005 08:50
Как сделать, чтобы блок вставлялся автоматом	Baron	Программирование	11	01.01.2004 20:01