Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → Как выглядит программно на VBA автозамена текста в автокаде
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Интересует как можно через вба в автокаде сделать автозамену. Для примера в ворде это выглядит так:
Sub Макрос1()
W.Selection.Find.ClearFormatting()
W.Selection.Find.Replacement.ClearFormatting()
With W.Selection.Find
.Text = 111
.Replacement.Text = 222
.Forward = True
.Wrap = wdFindContinue
End With
W.Selection.Find.Execute(Replace:=wdReplaceAll)
End Sub
Если речь идет о замене одной строки текста на другую, то:
-сформировать selectionset
-пройтись по всем объектам в selectionset и если текст равен искомому, то заменить на то, что нужно.
Варианты :
брать все объекты в чертеже или выбирать на экране
брать только TEXT или и MTEXT.
Пример - берутся только объекты TEXT, область поиска указывает пользователь.
Dim selectionSet1 As AcadSelectionSet
Set selectionSet1 = ThisDrawing.SelectionSets.Add("NewSelectionSet")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "TEXT"
sset.SelectOnScreen gpCode, dataValue
Dim ent As AcadEntity
For each ent sset
If ent.TextString="x" Then ent.TextString="y"
Next
ThisDrawing.SelectionSets("NewSelectionSet").DeleteЕсли надо искать во всем чертеже, то вместо
sset.SelectOnScreen gpCode, dataValue
надо
sset.Select acSelectionSetAll, , , gpCode, dataValue
Выдает ошибку: Compile error: Syntax error и выделяет строку For each ent sset
in пропустил
For each ent in sset
Советую азы VBA поучить, в частности, циклы.
А как их выучить, только по примерам?
П.С. выдает ошибку: "Object required", а когда второй раз задаешь выдает ошибку: "именной набор объектов уже существует"
Павел, значит то что предложили на DWG.ru на Lisp(с пакетной обработкой файлов) Вас не устраивает, попробуйте так на VBA
Public Sub test()
Dim old_txt, new_txt As String
old_txt = "111" ' здесь Ваш старый текст
new_txt = "222" ' здесь Ваш новый текст
Dim ss As AcadSelectionSet
Dim intType(0) As Integer, varData(0) As Variant
Dim ent As AcadEntity
intType(0) = 0: varData(0) = "TEXT"
Set ss = ThisDrawing.SelectionSets.Add("SSSELINSERT")
ss.Select acSelectionSetAll, filtertype:=intType, filterdata:=varData
For Each ent In ss
ent.TextString = Replace(ent.TextString, old_txt, new_txt)
Next ent
ss.Clear
ss.Delete
intType(0) = 0: varData(0) = "MTEXT"
Set ss = ThisDrawing.SelectionSets.Add("SSSELINSERT")
ss.Select acSelectionSetAll, filtertype:=intType, filterdata:=varData
For Each ent In ss
ent.TextString = Replace(ent.TextString, old_txt, new_txt)
Next ent
ss.Clear
ss.Delete
Dim blockRefObj As AcadBlockReference
Dim varAttributes As Variant
intType(0) = 0: varData(0) = "INSERT"
Set ss = ThisDrawing.SelectionSets.Add("SSSELINSERT")
ss.Select acSelectionSetAll, filtertype:=intType, filterdata:=varData
For Each blockRefObj In ss
varAttributes = blockRefObj.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
varAttributes(i).TextString = Replace(varAttributes(i).TextString, old_txt, new_txt)
Next i
blockRefObj.Update
Next blockRefObj
ss.Clear
ss.Delete
End Sub
Sorry, торопился, надергал из разных примеров, имена наборов получились разные.
Надо вместоSet selectionSet1 = ThisDrawing.SelectionSets.Add("NewSelectionSet") Set sset= ThisDrawing.SelectionSets.Add("NewSelectionSet")
Павел]
когда второй раз задаешь выдает ошибку: "именной набор объектов уже существует"
Из-за ошибки программа не доходит до конца, где происходит удаление набора.ThisDrawing.SelectionSets("NewSelectionSet").Delete
При повторном запуске код пытается создать новый набор с существующим именем.В начале программы рекомендую поместить:
If ThisDrawing.SelectionSets.Count > 0 Then For i = 1 To ThisDrawing.SelectionSets.Count ThisDrawing.SelectionSets.Item(0).Delete Next i End If
А как их выучить, только по примерам?
Книг по VBA полно, в т.ч. для скачивания в инете.
О спасибо огромное Anatoly и Дмитрий. Оба варианта прекрасно работают. Но в варианте Анатолия заменяет только TEXT, или MTEXT если заменить в строке: dataValue(0) = "TEXT", но как сделать что бы менял сразу все я не разобрался...
Так же в обоих вариантах меняет по всему чертежу и в листах, но не меняет в блоках...
П.С. а какой лучше мне начать изучать язык для подобных задач, VB или LISP? А то знакомый программист советует если начинать изучать программирование, то сразу с С++.
Dim gpCode(0 To 3) As Integer Dim dataValue(0 To 3) As Variant intData(0) = -4: varData(0) = "<OR" intData(1) = 0: varData(1) = "TEXT" intData(2) = 0: varData(2) = "MTEXT" intData(3) = -4: varData(3) = "OR>"
Насчет языка - смотря для каких целей.
Проще всего (по моему мнению) VBA, но его Autodesk грозится прекратить поддерживать.
Так, что перебираюсь потихоньку на VB.Net
Так же в обоих вариантах меняет по всему чертежу и в листах, но не меняет в блоках...
В блоках (если только это не динамический блок) текст (и все остальное) изменить нельзя (не считая масштаб, цвет и т.д.).
См. какую-нибудь книжку по автокаду (прежде, чем программировать хорошо бы с автокадом более-менее разобраться).
Можно менять аттрибуты в блоке.Вот пример чтения атрибутов.
Public Sub TestGetAttributes()
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim objBRef As AcadBlockReference
Dim varAttribs As Variant
Dim strAttribs As String
Dim intI As Integer
On Error Resume Next
With ThisDrawing.Utility
'' get an entity from user
.GetEntity objEnt, varPick, vbCr & "Pick a block with attributes: "
If Err Then Exit Sub
'' cast it to a blockref
Set objBRef = objEnt
'' exit if not a block
If objBRef Is Nothing Then
.Prompt vbCr & "That wasn't a block."
Exit Sub
End If
'' exit if it has no attributes
If Not objBRef.HasAttributes Then
.Prompt vbCr & "That block doesn't have attributes."
Exit Sub
End If
'' get the attributerefs
varAttribs = objBRef.GetAttributes
'' show some information about each
strAttribs = "Block Name: " & objBRef.Name & vbCrLf
For intI = LBound(varAttribs) To UBound(varAttribs)
strAttribs = strAttribs & " Tag(" & intI & "): " & _
varAttribs(intI).TagString & vbTab & " Value(" & intI & "): " & _
varAttribs(intI).TextString & vbCrLf
Next
End With
MsgBox strAttribs
End SubВ блоках (если только это не динамический блок) текст (и все остальное) изменить нельзя (не считая масштаб, цвет и т.д.).
Но ведь через стандартную автозамену можно менять и в блоках...
Да еще вопрос, по поводу того как через макрос менять текст в колонтитулах. Я использую такой макрос:
Sub test()
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "111"
.Replacement.Text = "222"
.Forward = True
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
но он в место того что бы менять, только активирует колонтитул...
В блоках (если только это не динамический блок) текст (и все остальное) изменить нельзя
С чего Вы взяли, все там можно менять
Public Sub test()
Dim old_txt, new_txt As String
old_txt = "111" ' здесь Ваш старый текст
new_txt = "222" ' здесь Ваш новый текст
Dim blkColl As AcadBlocks
Dim blkDef As AcadBlock
Dim entText As AcadText
Dim entMText As AcadMText
Set blkColl = ThisDrawing.Blocks
For Each blkDef In blkColl
For i = 0 To (blkDef.Count - 1)
If ((blkDef.Item(i).ObjectName = "AcDbText") Or (blkDef.Item(i).ObjectName = "AcDbMText")) Then
blkDef.Item(i).TextString = Replace(blkDef.Item(i).TextString, old_txt, new_txt)
End If
Next i
Next blkDef
ThisDrawing.Regen (acAllViewports)
End SubДмитрий, огромное вам спасибо! Это то, что нужно:)
С чего Вы взяли, все там можно менять
Вы же описание блока переопределяете, а я писал про BlockReference
Вы же описание блока переопределяете, а я писал про BlockReference
Ну значит я Вас не правильно понял, извиняюсь. Да я изменил описание блока, и сделав регенерацию для чертежа, переопределил все вхождения блоков в соответствии с новым описанием. Судя по всему автора темы это устроило
По-моему так лучше не делать, ибо это ведет к появлению в разных чертежах блоков с одинаковым именем, но разных по описанию.
А потом копируют блок из одного чертежа в другой и долго удивляются что случилось с блоком.
Не совсем понял, что означает "описание блока", то есть, если я поменяю в одном блоке то в других таких же блоках может не поменяться текст?
Вот про описание блока (Block Definition) и про вставку блока (BlockReference)
Blocks and Block References
The Block object represents a block definition, which contains a name and a set of entities.
Block objects have two elements:
• A block definition, which is the abstract database structure that defines a Block
object’s entities
• A block reference (or block insertion), which is the actual insertion in a drawing
Changing a block definition also changes every block reference in the drawing.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Как выглядит программно на VBA автозамена текста в автокаде
Форум работает на PunBB, при поддержке Informer Technologies, Inc
