Hi,I'm a beginner. I was hoping someone would show me why my first macro doesn't work.
I need a macro that will:
- Find any shape with outline.width = 0.2 mm, but just for the selected objects- Assign all located outline.width = 0.2 mm with a red color- Combine all located outline.width = 0.2 mm
Here is my code:----------------------------------------------------------------Sub dick_rot_kombi_5() Dim shs As Shapes, sh As Shape Set shs = ActiveSelection.Shapes ActiveDocument.Unit = cdrMillimeter If ActiveSelectionRange.Count = 0 Then MsgBox "Es ist kein Objekt ausgewählt!" Exit Sub Else If ActiveSelectionRange.Count = 1 Then MsgBox "Es ist nur 1 Objekt ausgewählt!" Exit Sub End If End If For Each sh In shs If sh.Outline.Width = 0.2 Then sh.Outline.Color.RGBAssign 255, 0, 0 End If Next sh Set shs = sh.Combine 'here appears an error "91" End Sub---------------------------------------------------------------------------------Any help would be appreciated, thanks!MarkusP.S: sorry for my english, it's not my native language.
Try this
Sub dick_rot_kombi_5() Dim shs As Shapes, sh As Shape, ns As New ShapeRange Set shs = ActiveSelection.Shapes ActiveDocument.Unit = cdrMillimeter If ActiveSelectionRange.Count = 0 Then MsgBox "Es ist kein Objekt ausgewählt!" Exit Sub Else If ActiveSelectionRange.Count = 1 Then MsgBox "Es ist nur 1 Objekt ausgewählt!" Exit Sub End If End If For Each sh In shs If sh.Outline.Width = 0.2 Then sh.Outline.Color.RGBAssign 255, 0, 0 ns.Add sh End If Next sh ns.Combine End Sub
Best regards
Mek
On a quick look -- perhaps Set shs = sh.Combine should be Set sh = shs.Combine
I'm thinking that because combine needs to work on a selection of objects (which shs is). But at the end of fhe final loop, sh will be the last object that was found, therefore only a single object. But I have not actually tested it.
[edit] but Mek's answer looks more complete -- you also need to have only the wanted objects selected at tha time, so shs will still contain too much.
Mek and HarryLondon, the code works perfectly!
thanks a lot for that !
Best regardsMarkus
Here is another way to do the same:
Dim sr As ShapeRange Set sr = ActivePage.Shapes.FindShapes(Query:="@outline.width = {.2 mm}") sr.SetOutlineProperties Color:=CreateRGBColor(255, 0, 0) sr.Combine
Happy Coding,
-Shelby
Shelby Moore said: Here is another way to do the same:
Thanks for showing another way (much simpler and quicker)