[CDR X5-X8] Выделение объектов в VBA

[ACBrew]

Здравствуйте. При разработке макроса в VBA столкнулся со следующей проблемой. Имеется несколько прямоугольников. Макрос создает внутри каждого из них новые прямоугольники с определенным смещением и помещает каждый из них в определенный слой. Суть проблемы встала в дальнейшем выборе этих объектов и экспорту.


Private Sub 1_Button_Click()
Dim sr As ShapeRange
Dim s As Shape
Dim xObRez As Double, yObRez As Double, shirObRez As Double, visObRez As Double
Dim sn As String
Dim z As Long
Dim fn As String
Dim ss As Shape

Set sr = ActiveSelectionRange
For Each s In sr
z = z + 1
Set ss = ActivePage.Layers("LayerN").Shapes(z)
ss.CreateSelection
ss.GetBoundingBox xObRez, yObRez, shirObRez, visObRez
sn = CStr(visObRez) + "x" + CStr(shirObRez)
MsgBox (sn)
Dim expopt As StructExportOptions
Set expopt = CreateStructExportOptions
expopt.UseColorProfile = False
fn = "C:\Users\Comp\Desktop\" + CStr(sn) + ".dxf"
Dim expflt As ExportFilter
Set expflt = ActiveDocument.ExportEx(fn, cdrDXF, cdrSelection, expopt)
With expflt
.BitmapType = 0 ' FilterDXFLib.dxfBitmapJPEG
.TextAsCurves = True
.Version = 13 ' FilterDXFLib.dxfVersion2008
.Units = 3 ' FilterDXFLib.dxfMillimeters
.FillUnmapped = True
.FillColor = 0
.Finish
End With

Next s

End Sub


По задумке выбираю внешний контур объекта, выделяю его и к выделенному контуру добавляю все содержимое. Никак не пойму где мой косяк, экспортируется только внешняя рамка

 

[_MBK_]

Правильно экспортируется. Вы по очереди выделяете каждый шейп а надо addtoselection делать

 

[ACBrew]

Т.е. мне необходимо перебрать все слои в заданном диапазоне используя AddToSelection и только после этого экспортировать?

 

[lev]

ss.CreateSelection - выделяет объект ss, сбрасывая выделение с других объектов

 

[ACBrew]

ss.CreateSelection использовалось для выбора границы ShapeRange. Т.е. если после этого вставить цикл

Dim ln As Layer
For Each ln In ActiveDocument.Layers.All
ss.AddToSelection
Next ln

Он включит все объекты в число выбранных? Или я неправильно понял принцип работы и есть способ проще?

 

[_MBK_]

Я вообще не пойму логику вашего макроса
Вам надо каждый объект по очереди в разные файлы записать?
Тогда все верно
Или все в один? Тогда у вас next не там стоит
Возможно у вас вот это имя CStr(visObRez) + "x" + CStr(shirObRez) для всех файлов одно и то же - тогда естественно они по очереди в один пишутся
если они и должны в один писаться но все вместе - тогда как я уже объяснил у вас цикл неправильно организован
Да и не нужен он тогда можно
ActivePage.Layers("LayerN").Shapes.addtoselection спопом сделать сразу

 

[ACBrew]

Если смотреть по картинке, то в данном случае должно получиться 2 файла, имя которых является размером внешнего контура. В файле должны получиться внешний контур и все внутренние. Т.е. 2 фигуры = 2 файла. Они на разных слоях и так должно и остаться.
Надеюсь не слишком замысловато объяснил

 

[_MBK_]

Не замысловато но и не сильно понятно
У вас имя формируется через некий sn=CStr(visObRez) + "x" + CStr(shirObRez)
Так вот я не вижу где эти значения в вашем цикле меняются
Надеюсь не слишком замысловато объяснил

 

[ACBrew]

Хм... вы правы. Логика макроса предполагалась следующая:
1. После создания мной прямоугольников определённого размера, я могу выбрать из них любое необходимое мне количество. Макрос осуществляет их переборку, создаёт в них внутренние контуры с определёнными отступами. Эти контуры сразу автоматически перемещаются на определённые слои. Результат работы этой части вы видите на прикреплённом изображении. Эту часть я "победил".
2. Далее я выделяю один или же несколько таких прямоугольников с внутренними контурами и жму сохранить. До выбора папки для сохранения я пока не дошёл и решил для начала реализовать это через экспорт в выбранную заранее папку. Макрос должен перебрать всё что я выделил и сохранить каждый прямоугольник с его внутренними контурами в отдельный файл. Т.е. если я изначально создам 5 прямоугольников и затем создам их внутренние контуры, то на выходе должно получиться 5 файлов. Каждый из них содержит "основной" прямоугольник и его внутренние контуры. Группировать их не получится, т.к. разбивка по слоям имеет важное значение. Имя файла должно соответствовать размеру "основного" прямоугольника.
Все эти "основные" прямоугольники лежат на одном слое. В макросе это LayerN. Я думал перебрать все шэйпы с этого слоя, выделяя его и добавляя к выделенному его внутренние контуры. Т.е. активируя этот шейп я получаю некую границу выделения и мне необходимо добавить к выделенному всё находящееся в ней и полученное сохранить. Размер этого шейпа и есть имя сохраняемого файла. Для это и нужно было sn=CStr(visObRez) + "x" + CStr(shirObRez).
Но вот добавить к выделенному шейпу "внутренние" у меня не выходит. Т.е. этот активируя этот шейп я получаю некую границу выделени и мне необходимо выделить всё находящееся в ней и полученное сохранить. Размер этого шейпа и есть имя сохраняемого файла. Пробовал записать макрос, выделить объект и сохранить вручную. Макрос использует CreateRangeFromArray().CreateSelection. Я слабоват в синтаксисе VBA и только пытаюсь его освоить и не придумал как это применить.
Поэтому и обратился за помощью.

 

[lev]

посмотрите в хелпе команду SelectShapesFromRectangle

 

[_MBK_]

Давайте еще раз по порядку. Сейчас у вас делается примерно так - перебираются шейпы внутри селекшна и параллельно шейпы на определенном слое. Инициализации переменных я в макросе не вижу - она вообще есть? Где используется текущий элемент выделения s я тоже не вижу. Вдобавок из вашего обьяснения я понял, что вы хотите менять выделение внутри цикла по элементам выделения (которые не используются вообще) Диагноз: безумный код, который непонятно почему рвботает хоть как то.

 

[ACBrew]

Дыр в коде хватает и он недоработан, я не спорю. Так вроде работает, но как я понял, он выбирает область, сохраняет все шейпы из этой области в один файл и поиск прекращается, т.к. теперь активна именно эта область...

Private Sub SaveButton_Click()
Dim sr As ShapeRange
Dim s As Shape
Dim xObRez As Double, yObRez As Double, shirObRez As Double, visObRez As Double
Dim sn As String
Dim fn As String

Set sr = ActiveSelectionRange
For Each s In ActivePage.Layers("LayerN").Shapes.All
If s.Selected = True Then
s.GetBoundingBox xObRez, yObRez, shirObRez, visObRez
ActivePage.SelectShapesFromRectangle xObRez, yObRez, xObRez + shirObRez, yObRez + visObRez, True
sn = CStr(visObRez) + "x" + CStr(shirObRez)
MsgBox (sn)
Dim expopt As StructExportOptions
Set expopt = CreateStructExportOptions
expopt.UseColorProfile = False
fn = "C:\Users\Quick\Desktop\" + CStr(sn) + ".dxf"
Dim expflt As ExportFilter
Set expflt = ActiveDocument.ExportEx(fn, cdrDXF, cdrSelection, expopt)
With expflt
.BitmapType = 0 ' FilterDXFLib.dxfBitmapJPEG
.TextAsCurves = True
.Version = 13 ' FilterDXFLib.dxfVersion2008
.Units = 3 ' FilterDXFLib.dxfMillimeters
.FillUnmapped = True
.FillColor = 0
.Finish
End With
End If
Next s

End Sub

 

[ACBrew]

Переправил. Теперь сохраняет как надо. Проверьте, пожалуйста, может что-то стоит доработать?

Private Sub SaveButton_Click()
Dim sr As ShapeRange
Dim s As Shape
Dim xObRez As Double, yObRez As Double, shirObRez As Double, visObRez As Double
Dim sn As String
Dim z As Integer
Dim fn As String
Dim m() As Variant

z = 1
Set sr = ActiveSelectionRange
For Each s In sr
z = z + 1
Next s
ReDim m(z, 4)
z = 1
For Each s In ActivePage.Layers("LayerN").Shapes.All
If s.Selected = True Then
s.GetBoundingBox xObRez, yObRez, shirObRez, visObRez
m(z, 1) = xObRez
m(z, 2) = yObRez
m(z, 3) = xObRez + shirObRez
m(z, 4) = yObRez + visObRez
z = z + 1
End If
Next s

For i = 1 To z - 1
ActivePage.SelectShapesFromRectangle m(i, 1), m(i, 2), m(i, 3), m(i, 4), True
sn = CStr(m(i, 4) - m(i, 2)) + "x" + CStr(m(i, 3) - m(i, 1))
MsgBox (sn)
Dim expopt As StructExportOptions
Set expopt = CreateStructExportOptions
expopt.UseColorProfile = False
fn = "C:\Users\Quick\Desktop\" + CStr(sn) + ".dxf"
Dim expflt As ExportFilter
Set expflt = ActiveDocument.ExportEx(fn, cdrDXF, cdrSelection, expopt)
With expflt
.BitmapType = 0 ' FilterDXFLib.dxfBitmapJPEG
.TextAsCurves = True
.Version = 13 ' FilterDXFLib.dxfVersion2008
.Units = 3 ' FilterDXFLib.dxfMillimeters
.FillUnmapped = True
.FillColor = 0
.Finish
End With
Next i


End Sub

 

[_MBK_]

Ну это же совсем другое дело. Можно, конечно, сделать в один цикл, но это уже перфекционизм.