VBA for ACAD |
Здравствуйте, гость ( Вход | Регистрация )
Here You Can Support Our Work and .:LavTeaM:. Services |
VBA for ACAD |
4.05.2009 - 10:16
Сообщение
#1
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
Может есть тут специалисты по VBА, хочу для ACADа на VBA реализовать след. вещь - поиск элементов (линий, блоков и т.д.) аналог команды - "_qselect". Для начала надо найти в чертеже все блоки с именем "*Ux", где х - лубое число от 0 до 1000 и выбрать их... можте кто поможет, подскажет...
или может кто пример скинет, чтобы просто выбирал все линии, а я потом разберусь как нить... Спасибо... Жду... |
|
|
4.05.2009 - 22:35
Сообщение
#2
|
|
Новичок Группа: Пользователи Пользователь №: 85877 Сообщений: 2 Регистрация: 8.02.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 2 раз(а) |
Public Sub purgeLines()
Dim obj As Object For Each obj In ModelSpace If TypeName(obj) = "IAcadLine" Then Dim line As AcadLine Set line = obj line.Delete End If Next End Sub |
|
|
4.05.2009 - 23:04
Сообщение
#3
|
|
Новичок Группа: Пользователи Пользователь №: 85877 Сообщений: 2 Регистрация: 8.02.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 2 раз(а) |
Для ссылок на блоки (сами определения остаются):
Код Public Sub purge()
Dim obj As Object For Each obj In ModelSpace If TypeName(obj) = "IAcadBlockReference" Then Dim blckref As AcadBlockReference Set blckref = obj If blckref.Name = "test" Then blckref.Delete End If End If Next End Sub |
|
|
4.05.2009 - 23:34
Сообщение
#4
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
А что делать, если блоки лежат в пространствах листов?
По-моему, более верным будет код наподобие Код Option Explicit Public Sub EraseBlocks(Optional sBlockName As String) Dim blkRef As AcadBlock If IsMissing(sBlockName) Then sBlockName = "*" On Error Resume Next For Each blkRef In ThisDrawing.Blocks blkRef.Erase Next blkRef Dim oLayout As AcadLayout, blkLay As AcadBlock, oEnt As AcadEntity For Each oLayout In ThisDrawing.Layouts Set blkLay = oLayout.Block For Each oEnt In blkLay If oEnt.ObjectName = "AcDbBlockReference" And UCase(oEnt.Name) Like UCase(sBlockName) Then oEnt.Delete End If Next oEnt Next oLayout End Sub Вечно путаю методы .Erase и .Delete, так что проверяйте. |
|
|
5.05.2009 - 09:09
Сообщение
#5
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
я как то сделал быстрее...
Цитата Dim blockObj As AcadBlock MsgBox "я нашел - " & ThisDrawing.Blocks.count - 3 & " блока(ов)" For k = 3 To ThisDrawing.Blocks.count - 1 Next k но я нашел блоки не на листе, а существующие блоки, среди имен "count" есть и мои блоки, имя я могу найти как "ThisDrawing.Blocks.Item(k).Name", где к от 3 до ThisDrawing.Blocks.count - 1, но дальше тупик, как применить Explode, к AcadBlock нельзя, только к AcadBlockReference. Как мне перейти от AcadBlock к AcadBlockReference? или у меня путь не тот... т.к. как найти какие блоки вставлены в чертеж и к ним применить Explode? --- пример посмотрю, спасибо... Сообщение отредактировал Agens - 5.05.2009 - 09:10 |
|
|
5.05.2009 - 09:21
Сообщение
#6
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Ты вот что определи - у тебя имена блоков твоих есть? Если да, то как вариант (я код не проверял):
Код Type typLayer
oPointer As Object IsLock As Boolean IsFrozen As Boolean End Type Public Sub ExplodeBlocksExcule(Optional sBlockNameExclude As String) If IsMissing(sBlockNameExclude) Then sBlockNameExclude = "*" Else sBlockNameExclude = UCase(sBlockNameExclude) End If Dim oLayer As AcadLayer, arLayers() As typLayer, iCounter As Integer ReDim arLayers(ThisDrawing.Layers.Count - 1) iCounter = 0 On Error Resume Next For Each oLayer In ThisDrawing.Layers arLayers(iCounter).oPointer = oLayer arLayers(iCounter).IsFrozen = oLayer.Freeze arLayers(iCounter).IsLock = oLayer.Lock oLayer.Freeze = False oLayer.Lock = False Next oLayer On Error GoTo 0 Dim oBlockDef As AcadBlock, oEnt As AcadEntity For Each oBlockDef In ThisDrawing.Blocks For Each oEnt In oBlockDef If oEnt.ObjectName = "AcDbBlockReference" And UCase(oEnt.Name) Like sBlockNameExclude Then oEnt.Explode oEnt.Erase End If Next oEnt Next oBlockDef On Error Resume Next For iCounter = 0 To UBound(arLayers) arLayers(iCounter).oPointer.Lock = arLayers(iCounter).IsLock arLayers(iCounter).oPointer.Freeze = arLayers(iCounter).IsFrozen Next iCounter End Sub |
|
|
5.05.2009 - 09:35
Сообщение
#7
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
уфф... я не такой спец по VBA, в этом коде ничего не понимаю... я думал - все просто...
есть ACADBlocks в чертеже (допусти три блока с именем 1, 2 и 3) блоки 1 и 2 уже вставлены в чертеж, а блок 3 просто существует... мне надо найти из блок с именем 2 и разчленить его... буду сам думать... |
|
|
5.05.2009 - 09:43
Сообщение
#8
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Я тоже предпочитаю VisualLISP А так-то по логике все просто: сначала разблокируются и включаются все слои; потом проходим по коллекции блоков. Внутри каждого описания блока проходим по элементам этого блока (пользуясь тем, что, например, пространство модели - тоже описание блока). Если, уже находясь внутри описания какого-то блока, натыкаемся на AcDbBlockReference (то есть вхождение блока), и имя этого блока похоже на sBlockNameExclude, то мы этот элемент расчленяем и удаляем. А потом восстановление состояния слоев в исходное состояние.
P.S. Вызывать код можно как Код Sub Test()
ExplodeBlocksExcule 'разбить вообще все блоки End Sub Sub Test1() ExplodeBlocksExcule "2" 'Разбить все блоки с именем "2" End Sub Sub Test2() ExplodeBlocksExcule "*2*" ' Разбить все блоки с именами, в которых содержится цифра 2 End Sub Сообщение отредактировал kpblc - 5.05.2009 - 09:45 |
|
|
5.05.2009 - 12:42
Сообщение
#9
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
короче сделал я все проще
Цитата Private Sub CommandButton1_Click() Dim blockObj As AcadBlock If Left(ThisDrawing.Blocks.Item(k).Name, 2) = "имя" Then stopflag = Val(Right(ThisDrawing.Blocks.Item(k).Name, Len(ThisDrawing.Blocks.Item(k).Name) - 2)) End If Dim objSelSet As AcadSelectionSet Dim objSelCol As AcadSelectionSets Dim intType(0) As Integer Dim varData(0) As Variant Set objSelCol = ThisDrawing.SelectionSets For Each objSelSet In objSelCol If objSelSet.Name = "blocks" Then objSelSet.Delete Exit For End If Next Set objSelSet = ThisDrawing.SelectionSets.Add("blocks") mode = acSelectionSetAll intType(0) = 0 'Фильтры выбора varData(0) = "INSERT" '"INSERT" для выбора блока 'objSelSet.SelectOnScreen intType, varData objSelSet.Select mode, 0, 0, intType, varData Set SelectOnlyOnScreen = objSelSet Set acSelSet = SelectOnlyOnScreen For I = 0 To acSelSet.count - 1 Next I MsgBox "Найдено и разбито " & CStr(acSelSet.count) & " блока(ов)..." End Sub но тут со своими тонкостями... |
|
|
5.05.2009 - 12:49
Сообщение
#10
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Ага, с тонкостями... Не обрабатываются "вложенные" блоки. В фильтре выбора нет дополнительной фильтрации по имени блока. В коде нет прямого указания на разбитие блока.
|
|
|
5.05.2009 - 14:01
Сообщение
#11
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
я не показывал эту часть...
Цитата ... Set objSelSet = ThisDrawing.SelectionSets.Add("blocks") mode = acSelectionSetAll intType(0) = 0 varData(0) = "INSERT" objSelSet.Select mode, 0, 0, intType, varData Set SelectOnlyOnScreen = objSelSet Set acSelSet = SelectOnlyOnScreen For i = 0 To acSelSet.count - 1 del_flag = 0 For j = stopflag - acSelSet.count - 1 To stopflag numb = Right(Str(j), Len(Str(j)) - 1) block_name = "*U" + numb If objSelSet.Item(i).Name = block_name Then objSelSet.Item(i).Explode del_flag = 1 End If Next j If del_flag = 1 Then objSelSet.Item(i).Delete Next i Вчера только начал разбираться с МИФом для Акада... Книги нет толковой, да и времени... Сообщение отредактировал Agens - 5.05.2009 - 14:19 |
|
|
5.05.2009 - 14:03
Сообщение
#12
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
.Delete просто удалит блок. А где разбитие?
Я зануда та еще |
|
|
5.05.2009 - 14:23
Сообщение
#13
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
|
|
|
5.05.2009 - 14:25
Сообщение
#14
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
А нету у меня такой книги. Встроенной справки зачастую достаточно. Правда, на английском
А для сложных вопросов и существуют форумы |
|
|
5.05.2009 - 14:31
Сообщение
#15
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
kpblc, вот у меня objSelSet.Item(i).Name - это имя блока, objSelSet.Item(stopflag - 1).Layer - имя слоя этого блока...
как мне тут сделать фильтр, что если слой с именем objSelSet.Item(stopflag - 1).Layer заблокирован, то то-то objSelSet.Item(stopflag - 1).Layer.Lock = False не получается т.е. хочу написать if objSelSet.Item(stopflag - 1).Layer(слой) = заблокирован, то objSelSet.Item(i).Delete не надо!!! Помоги, а!!! |
|
|
5.05.2009 - 14:34
Сообщение
#16
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Сейчас лиспом машина занята по самое не хочу, поэтому пишу насухую
Код If Not (ThisDrawing.Layers.Item(objSelSet.Item(i).Layer).Lock) Then по идее для коллекции слоев допускается и нормально срабатывает Item(ИмяСлоя).objSelSet.Item(i).Explode objSelSet.Item(i).Erase End If --- Исправил 1 опечатку и положение 1 скобки Сообщение отредактировал kpblc - 5.05.2009 - 14:35 |
|
|
5.05.2009 - 14:41
Сообщение
#17
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
Спасибо... работает... эх... я тоже так хочу "шарить" в VBA...
добавил строчку с Freeze у себя Сообщение отредактировал Agens - 5.05.2009 - 14:43 |
|
|
5.05.2009 - 14:43
Сообщение
#18
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Пока не забыл: для полноты картины я бы задумался еще и о замороженных слоях.
<offtop>Я немного соображаю в лиспе и на основе этого пишу VBA-шный код... Грубо говоря, "портирую" код Но за добрые слова спасибо Приятно, черт возьми </offtop> Сообщение отредактировал kpblc - 5.05.2009 - 14:45 |
|
|
5.05.2009 - 15:06
Сообщение
#19
|
|
Завсегдатай Группа: Пользователи Пользователь №: 89781 Сообщений: 104 Регистрация: 28.04.2008 Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 10 раз(а) |
слушай, а ты не знаеешь, как сделать так, чтобы пока команда ThisDrawing.SendCommand, посланная в командрую строку не выбрала рамку (я не выбрал рамку ), остальной макрос не выполнялся?
|
|
|
5.05.2009 - 15:14
Сообщение
#20
|
|
Свой человек Группа: Пользователи Пользователь №: 9904 Сообщений: 652 Регистрация: 31.01.2005 Из: С.-Петербург Загружено: байт Скачано: байт Коэффициент: --- Спасибо сказали: 36 раз(а) |
Стоп. А что ты посылаешь в ком.строку? Если набор формировать, то смотри SelectSets.Add (да и так у тебя уже есть аналог; ключи только надо поменять).
|
|
|
Текстовая версия | Сейчас: 19.04.2024 - 22:58 |