I've just inherited an Excel app that draws an org chart. Each shape is connected by a Line
However, I need to remove the shadow that is drawn when each line is added. How do I get a collection of Lines so that I can do something like
Line.Shadow.Transparency = 1.0
I'm a bit of a vba newbie :-)
This should do the trick - it loops through all shapes, checks if they're a line, then removes the shadow.
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim shapeObj
For Each shapeObj In ActiveSheet.Shapes
If shapeObj.Type = 9 Then
Dim objName$
objName = shapeObj.Name
ws.Shapes.Range(Array(objName)).Shadow.Visible = msoFalse
End If
Next shapeObj
End Sub
Edit: Turns out, per OP, the shapes are grouped, so he used this to get it:
Sub RemoveLineShadows()
For Each Shp In ORG.Shapes
If Shp.Type = msoGroup Then
For X = 1 To Shp.GroupItems.Count
If Shp.GroupItems(X).Type = msoLine Then
Shp.GroupItems(X).Shadow.Transparency = 1
End If
Next X
End If
Next Shp
End Sub
Sub qqq()
Dim x As Shape
For Each x In ActiveSheet.Shapes
x.Shadow.Visible = msoFalse
Next
End Sub
Related
I'm trying to turn off gradient fill in all shapes in a PowerPoint document (including groups and sub groups).
The thing is I can't even get to cycle through the shapes correctly
Sub solid()
Set myDocument = ActivePresentation.Slides(1)
For Each sh In myDocument.Shapes
sh.Fill.solid
Next
End Sub
Thanks for your help.
Sub solid()
Dim mydocument As Presentation
Set mydocument = ActivePresentation
Dim sh As Shape
Dim sl As Slide
For Each sl In mydocument.Slides
For Each sh In sl.Shapes
If HasGradient(sh) = True Then
sh.Fill.solid
End If
Next
Next
End Sub
And also implement this function from TheSpreadSheetGuru to check whether the shape has a gradient value.
Function HasGradient(shp As Shape) As Boolean
'PURPOSE: Determine if a shape object contains a gradient format property
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim GradientStopCount As Long
'Test for Gradient Stops
On Error Resume Next
GradientStopCount = shp.Fill.GradientStops.Count
On Error GoTo 0
'Results
If GradientStopCount <> 0 Then
HasGradient = True
Else
HasGradient = False
End If
End Function
How do I group all objects (or "shapes"?) on a slide and resize that group?
Subsequently the "big" group should be ungrouped.
My attempt fails with "function expected":
Sub Group_And_Resize()
Dim Sld As Slide
With Sld.Shapes
With .SelectAll.Group //Error here
.Width = 907
End With
End With
End Sub
By manual experimentation, I learned that some objects (or "shapes"?) cannot be added to a group, such as slide numbers which are automatically generated. Is there any possibility to exclude those from the selection?
If you want to group the shapes together first and then set the overall width to 907, you can use this code:
Sub Group_And_Resize()
Dim Sld As Slide, a As Variant, i As Integer
Set Sld = ActivePresentation.Slides(1) ' your slide
ReDim a(1 To Sld.Shapes.Count)
For i = LBound(a) To UBound(a)
a(i) = Sld.Shapes(i).Name
Next
Sld.Shapes.Range(a).Group.Width = 907
End Sub
If you want to make the width of each of the shapes on the slide = 907, you can use the following code:
Sub Group_And_Resize()
Dim Sld As Slide
Set Sld = ActivePresentation.Slides(1) ' your slide
Sld.Shapes.Range.Width = 907
End Sub
This is based on Алексей Р's answer but solves a few problems and also is more generic. It allows calling the routine on any slide in the active presentation and setting the width to any desired value. See comments for more details.
Sub Test()
With ActivePresentation
Call Group_And_Resize(.Slides(1), 200)
End With
End Sub
Sub Group_And_Resize(Sld As Slide, sngWidth As Single)
Dim a As Variant, i As Long ' Array indices are longs, not integers
Dim oGroup As Shape
' Call NonPlaceholderShapeCount to get number of
' shapes that are not placeholders, since placeholders
' cannot be grouped. Use that to ReDim the array:
ReDim a(1 To NonPlaceholderShapeCount(Sld))
For i = LBound(a) To UBound(a)
' Again, make sure we don't try to group placeholders
If Not Sld.Shapes(i).Type = msoPlaceholder Then
a(i) = Sld.Shapes(i).Name
End If
Next
' Get a reference to the new group
' since we need to set several properties on it
Set oGroup = Sld.Shapes.Range(a).Group
' This ensures that the group (and its shapes)
' aren't distorted:
oGroup.LockAspectRatio = True
' and finally, set the width
oGroup.Width = sngWidth
End Sub
Function NonPlaceholderShapeCount(Sld As Slide) As Long
' Returns the number of non-placeholder shapes on Sld
Dim x As Long
Dim lCount As Long
With Sld
For x = 1 To .Shapes.Count
If Not .Shapes(x).Type = msoPlaceholder Then
lCount = lCount + 1
End If
Next
End With
NonPlaceholderShapeCount = lCount
End Function
I am looking for a way to kind of re-engineer the VBA code I need to create a certain visual in PowerPoint.
For example purposes let's say, I want to create code to create this:
Right now I have wrote the following VBA code that allows you highlight the shapes used in the powerpoint:
Sub ListAllShapes()
Dim curSlide As Slide
Dim curShape As Shape
For Each curSlide In ActivePresentation.Slides
Debug.Print curSlide.SlideNumber
For Each curShape In curSlide.Shapes
MsgBox curShape.Name
Next curShape
Next curSlide
End Sub
If I run this with my example I get the following output:
Autoshape 7
However when I then lookup the Shape.name here: https://learn.microsoft.com/en-us/office/vba/api/office.msoautoshapetype I see that Autoshpape 7 is msoShapeIsoscelesTriangle. If I then insert the following code:
Sub InsertShape()
Set myDocument = ActivePresentation.Slides(1)
myDocument.Shapes.AddShape Type:=msoShapeIsoscelesTriangle, _
Left:=50, Top:=50, Width:=100, Height:=200
End Sub
I get a different graph, any thoughts on where I am going wrong?
The autoshape Name is not the autoshape Type. They're 2 different properties. Here's a macro to add all the shapes to a slide. Then look up the number on this page to get the VBA AutoshapeType name: MsoAutoShapeType enumeration
Sub MakeShapes()
Dim T As Long, L As Long
Dim oShape As Shape, oText As Shape
T = 0
L = 0
x = 1
For y = 1 To 15
For Z = 1 To 26
On Error GoTo NoShape
Set oShape = ActiveWindow.Selection.SlideRange.Shapes.AddShape(Type:=x, Left:=L, Top:=T, Width:=30, Height:=30)
On Error GoTo -1
Set oText = ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=L, Top:=T + 36, Width:=36, Height:=18)
With oText.TextFrame2.TextRange
.Text = oShape.AutoShapeType
.Font.Size = 10
End With
Set oShape = Nothing
Set oText = Nothing
L = L + 36
NoShape:
x = x + 1
If x = 184 Then Exit Sub
Next Z
L = 0
T = T + 71
Next y
End Sub
I need to delete all shapes except command buttons. Or to delete just ovals, straight lines and drawn lines.
Sub deleteShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
End Sub
In this answer Jamie Bull deletes the shapes:
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
But how can I get my command buttons types? Or other objects types? I tried
Sub testShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
MsgBox (shp.Type)
Next shp
End Sub
but it gives only numbers: 9, 5, 1, 12. I don't know which number is which shape. Is there any way to get an inner name like msoOLEControlObject or at least to make sure number 1 is really Command button?
A list of types is here: https://msdn.microsoft.com/en-us/VBA/Office-Shared-VBA/articles/msoshapetype-enumeration-office
All values are defined as constants in VBA, so you can write
if not shp.Type = msoOLEControlObject then
shp.Delete
end if
To get more infos about what kind of control you have:
Dim sh As Shape
For Each sh In Activesheet.Shapes
Debug.Print sh.Name, sh.Type
If sh.Type = msoFormControl Then
Debug.Print " msoFormControl:" & sh.FormControlType
End If
If sh.Type = msoOLEControlObject Then
Debug.Print " msoOLEControlObject: " & TypeName(sh.OLEFormat.Object.Object)
End If
Next sh
The FormControlType are shows here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlformcontrol-enumeration-excel - all are also defined as VBA constants
If you are using the default Names for the Shapes, then for Forms buttons:
Sub poiuyt()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 6) = "Button" Then
Else
shp.Delete
End If
Next shp
End Sub
and if the button are activex then:
Sub trewq()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 13) = "CommandButton" Then
Else
shp.Delete
End If
Next shp
End Sub
This approach is valid only if the Names are of the default type.
I'm getting a "Object variable or With block variable not set" error in my code.
This is my first crack at macro writing. I do have programming knowledge but this is new to me.
Anyway, I want to go through the presentation, and for every page that has any text in the notes section, I want to add a new slide (following it) containing that text.
Here's what I tried:
Sub SlideSort()
Dim curSlide As Slide
Dim newSld As Slide
Dim curPres As Presentation
Dim curShape As Shape
Dim i As Integer
For i = 1 To ActivePresentation.Slides.Count
curSlide = ActivePresentation.Slides(i)
For Each curShape In curSlide.NotesPage.Shapes
If curShape.Type = msoPlaceholder Then
If curShape.PlaceholderFormat.Type = ppPlaceholderBody Then
If curShape.TextFrame.TextRange <> "" Then
Set newSld = ActivePresentation.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
newSld.Shapes(2).TextFrame.TextRange = curShape.TextFrame.TextRange
i = i + 1
End If
End If
End If
Next curShape
Next i
End Sub
The line that gives the error is curSlide = ActivePresentation.Slides(i)
Use Set curSlide = ActivePresentation.Slides(i) - it's an object, and should be operated via Set.
You need to use Set here, as you have with other objects:
Set curSlide = ActivePresentation.Slides(i)
Bingo. It's a bug in the Mac version of PowerPoint. I can repro the problem on the Mac.
.PlaceholderFormat.Type isn't supported on Mac PowerPoint, though it should be.
It's not 100% reliable, but you can pick up the second shape on the notes page as the body text placeholder instead:
Sub SlideSort()
Dim curSlide As Slide
Dim newSld As Slide
Dim curPres As Presentation
Dim curShape As Shape
Dim i As Integer
For i = 1 To ActivePresentation.Slides.Count
curSlide = ActivePresentation.Slides(i)
curShape = curSlide.NotesPage.Shapes(2)
If curShape.TextFrame.TextRange <> "" Then
Set newSld = ActivePresentation.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
newSld.Shapes(2).TextFrame.TextRange = curShape.TextFrame.TextRange
i = i + 1
End If
Next i
End Sub
I suspect you may also run into issues because you're looking at Slide.Count in the loop, but by adding slides, you're modifying Slide.Count.