#1
|
|||
|
|||
Alter Thickness of All Circles in Document
I have a document created by someone else with nearly 100 pages and probably 1000 circles. I need to write some vba code to change the thickness to 4.5 (it is currently 0.75).
I have never written any vba code before, but have used small sections obtained online in the past. Any help would be greatly appreciated. I'm thinking the code would need to select the shape, set the thickness then move onto the next shape altering the same property in a loop. Here is what i have so far... Sub CircleThickness() With ActiveDocument.Shapes(1) .AutoShapeType = msoShapeOval .Line.Weight = 4.5 End Sub |
#2
|
|||
|
|||
If you all the shapes are in fact AutoShapes and AutoShapeType msoTypeOval then this should work:
Sub ResetShapeLineWT() Dim oShp As Shape For Each oShp In ActiveDocument.Shapes If oShp.AutoShapeType = msoShapeOval Then oShp.Line.Weight = 4.5 End If Next End Sub |
#3
|
|||
|
|||
Thanks! - that worked for all the typical circles. There are circles that were unaffected by the code inside a rectangle with rounded corners and also appear to be on a drawing canvas.
When I look at the selection pane - those "ovals" are part of a numbered 'canvas' - do you have a way to modify the circles on the canvas as well? |
#4
|
||||
|
||||
I haven't played with the drawing canvas before. This appears to work
Code:
Sub ResetShapeLineWT() Dim oShp As Shape, oCShp As CanvasShapes, i As Integer For Each oShp In ActiveDocument.Shapes If oShp.AutoShapeType = msoShapeOval Then oShp.Line.Weight = 4.5 ElseIf oShp.CanvasItems.Count > 0 Then For i = 1 To oShp.CanvasItems.Count If oShp.CanvasItems(i).AutoShapeType = msoShapeOval Then oShp.CanvasItems(i).Line.Weight = 4.5 End If Next i End If Next End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
I got an error - "This member can only be accessed for a group"
debug has an issue with "ElseIf oShp.CanvasItems.Count > 0 Then" see attached screenshots. |
#6
|
|||
|
|||
Try this:
Code:
Sub ResetShapeLineWT2() Dim oShp As Shape Dim lngIndex As Long For Each oShp In ActiveDocument.Shapes Select Case oShp.Type Case 1 If oShp.AutoShapeType = msoShapeOval Then oShp.Line.Weight = 4.5 End If Case 20 For lngIndex = 1 To oShp.CanvasItems.Count If oShp.CanvasItems(1).Type = 1 Then If oShp.CanvasItems(1).AutoShapeType = msoShapeOval Then oShp.CanvasItems(1).Line.Weight = 4.5 End If End If Next End Select Next End Sub |
#7
|
|||
|
|||
No errors, it just didn't change the circles inside the drawing canvas. It did change the other circles, however.
|
#8
|
||||
|
||||
Which might be because your ovals inside canvas items are grouped. The grouping of objects can get complicated with groups inside groups.
You are going to need to provide a sample document containing items that the macro is not currently hitting. If your canvas items have different levels of grouping then you need to provide samples of each.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#9
|
|||
|
|||
Here the example document. I attached it to the original post, but here it is again.
|
#10
|
|||
|
|||
This one shows the circles on the left that are being correctly adjusted and the circles on the right that are un-effected by the code.
|
#11
|
|||
|
|||
Try this:
Code:
Sub ResetShapeLineWT2() Dim oShp As Shape Dim lngIndex As Long For Each oShp In ActiveDocument.Shapes Select Case oShp.Type Case 1 If oShp.AutoShapeType = msoShapeOval Then oShp.Line.Weight = 4.5 End If Case 20 For lngIndex = 1 To oShp.CanvasItems.Count If oShp.CanvasItems(lngIndex).Type = 1 Then If oShp.CanvasItems(lngIndex).AutoShapeType = msoShapeOval Then oShp.CanvasItems(lngIndex).Line.Weight = 4.5 End If End If Next End Select Next oShp End Sub |
#12
|
|||
|
|||
It worked!!! thank you so much!! After running the code on the test document, I also ran it on the two actual documents containing 75 pages and 100 pages each and all the circles have been successfully changed. Thanks again.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How do you alter font/size within Task folders | lsg267 | Office | 0 | 06-16-2017 07:45 AM |
divided circles | ericvorlage | Excel | 1 | 01-26-2014 11:07 AM |
End or alter a loop? | DJSOUND | Word VBA | 1 | 10-11-2013 08:11 PM |
Alter right click menu? | markg2 | Office | 1 | 01-10-2011 08:10 AM |
Circles | Toruk-Mach-Toh | Word | 0 | 03-16-2010 05:33 AM |