Alter Thickness of All Circles in Document

wolverineblaine · #1 03-18-2019, 11:29 AM

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

gmaxey · #2 03-18-2019, 12:32 PM

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

wolverineblaine · #3 03-18-2019, 07:03 PM

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?

Guessed · #4 03-18-2019, 07:50 PM

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

wolverineblaine · #5 03-19-2019, 05:33 AM

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.

gmaxey · #6 03-19-2019, 01:04 PM

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

wolverineblaine · #7 03-19-2019, 02:20 PM

No errors, it just didn't change the circles inside the drawing canvas. It did change the other circles, however.

Guessed · #8 03-19-2019, 03:07 PM

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.

wolverineblaine · #9 03-20-2019, 09:28 AM

Here the example document. I attached it to the original post, but here it is again.

wolverineblaine · #10 03-20-2019, 11:31 AM

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.

gmaxey · #11 03-20-2019, 01:54 PM

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

wolverineblaine · #12 03-20-2019, 08:02 PM

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