I usually use this one couple times for converting charts to image in PPT. But this time, when running this code, it shown " Error 242, Subject Required"
Anyone master of VBA can help me fix it?
Here the code:
`Sub EnumChartsInPresentation()
Dim sld As Slide
Dim shp As Shape
Dim ctr As Long
For Each sld In ActivePresentation.Slides
For ctr = sld.Shapes.Count To 1 Step -1
If GetShapeType(sld.Shapes(ctr)) = msoChart Then
Call ConvertChartToImage(sld, sld.Shapes(ctr))
End If
Next
Next
End Sub
Function GetShapeType(shp As Shape) As MsoShapeType
If shp.Type = msoPlaceholder Then
If shp.PlaceholderFormat.ContainedType = msoChart Then
GetShapeType = msoChart
Exit Function
End If
End If
GetShapeType = shp.Type
End Function
Sub ConvertChartToImage(sld As Slide, shp As Shape)
Dim shpChartImage As Object
shp.Copy
DoEvents
Set shpChartImage = sld.Shapes.PasteSpecial(ppPastePNG)
With shpChartImage
.Left = shp.Left
.Top = shp.Top
Do While shp.ZOrderPosition < shpChartImage.ZOrderPosition
Call shpChartImage.ZOrder(msoSendBackward)
Loop
shp.Visible = False
'shp.Delete
'Set shp = Nothing
End With
End Sub`
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I have an issue aligning shapes using VBA on PowerPoint (office 360).
I know I can use .Shapes.Range.Align msoAlignBottom, msoFalse
but I don't understand how to make it work with a specific shape name as I always have an error or nothing is happening.
This is the code in which I would like to implement this action:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
On Error Resume Next
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSh.Shapes.Range.Align msoAlignBottom, msoTrue
End Select
End If
Next oSh
Next oSl
End Sub
Thank you very much for your help,
Try this code:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
'sn = InputBox("Enter the name of the shape")
sn = "Name1" 'debug
'On Error Resume Next
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.Type 'placeholder or not placeholder?
Case msoPlaceholder
' it's a placeholder! check the placeholder's type
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
'do smth with placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Case Else 'it's not a placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I also recommend removing the On Error Resume Next statement because it hides errors and you don't get useful information about how the code works.
You have to create a ShapeRange that includes the shapes you want to align. Since you are keying off the name of the shape, the example below shows how a wildcard can be used.
Option Explicit
Sub Test()
LineUpShapes 1, "Rectangle", msoAlignTops
End Sub
Sub LineUpShapes(ByVal SlideNumber As Long, _
ByVal ShapeName As String, _
ByVal alignment As MsoAlignCmd)
Dim sl As Slide
Set sl = ActivePresentation.Slides(SlideNumber)
Dim namedShapes() As Variant
Dim shapeCount As Integer
Dim sh As Shape
For Each sh In sl.Shapes
If sh.Name Like (ShapeName & "*") Then
shapeCount = shapeCount + 1
ReDim Preserve namedShapes(shapeCount) As Variant
namedShapes(shapeCount) = sh.Name
Debug.Print "shape name " & sh.Name
End If
Next sh
Dim shapesToAlign As ShapeRange
Set shapesToAlign = sl.Shapes.Range(namedShapes)
shapesToAlign.Align alignment, msoFalse
End Sub
Thank you so much Алексей!
I have readapted your code and it works perfectly! It is always a placeholder in my case ;)
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
If ActivePresentation.Slides(1).Shapes("Rectangle 5").ActionSettings(ppMouseClick).Action = ppActionRunMacro(CorrectAnswer) Then
MsgBox "YEET"
End If
How do I make a MsgBox pop-up if a certain shape has a certain macro to it?
If your rectangle's ActionSettings are set like this
Sub Setup()
Dim ppt As Presentation
Set ppt = ActivePresentation
With ppt.Slides(1).Shapes("Rectangle 3").ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "CorrectAnswer"
End With
End Sub
Public Sub CorrectAnswer()
Debug.Print "show the correct answer"
End Sub
Then you can detect which shape has the macro you're looking for with
Sub test()
Dim ppt As Presentation
Set ppt = ActivePresentation
Dim sld As Slide
For Each sld In ppt.Slides
Dim shp As Shape
For Each shp In sld.Shapes
If shp.Name Like "Rectangle*" Then
If shp.ActionSettings(ppMouseClick).Run = "CorrectAnswer" Then
MsgBox "YaYaYeet"
End If
End If
Next
Next sld
End Sub
Your syntax is causing you the error.
Following is the correct syntax:
.ActionSettings.(ppMouseClick).Run = "CorrectAnswer"
I am trying to create a hyperlink on the newly created shape oSh to the newly created slide oSlide through VBA.
The shape is on a different slide than the newly created slide.
Code to create the shape and the slide.
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If Sld.SlideIndex <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
Call AddCustomSlide
Unload UserForm1
End Sub
Sub AddCustomSlide()
'Create new slide
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
If oSlide.Shapes.HasTitle = msoTrue Then
oSlide.Shapes.Title.TextFrame.TextRange.Text = TextBox1
End If
'Add SmartArt
'Set Shp = oSlide.Shapes.AddSmartArtApplication.SmartArtLayouts(1)
'Create Flowchart Shape
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeFlowchartPredefinedProcess, 50, 100, 83.52, 41.62)
With oSh
With .TextFrame.TextRange
.Text = TextBox1
With .Font
.Name = "Verdana (Body)"
.Size = 8
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = RGB(255, 255, 255)
End With ' Font
End With ' TextRange
End With ' oSh, the shape itself
End Sub
I'm guessing you want this in the last part that does the font formatting:
Dim URLorLinkLocationText as String
With oSh.TextFrame.TextRange.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.SubAddress = URLorLinkLocationText
End With
I do presentations with background wipes that are flowchart process shapes with the text "wipey" for yellow wipes and "wipeb" for blue wipes. When working out the animations for training slides, I place the wipes in front with 0.75 transparency. Once the wipe-animation order is correct and the wipes properly placed, I move the wipes behind the text with 0 transparency.
My Wipe_Back macro works fine but my Wipe_Front macro is only getting some of the wipes each time it is called. I have to call it multiple times to get all of the shapes moved forward. the macros are almost identical so I am not sure what I am doing wrong, but I am a VBA newbie-ish!
both macros are shown below and I am also open to recommendations on more elegant practices in the code.
Wipe_Back (seems to work):
Sub Wipe_Back()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
shp.Fill.Transparency = 0
shp.ZOrder msoSendToBack
'shp.Fill.Transparency = 0.75
'shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
Wipe_Front does not consistently work:
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
If shp.TextFrame.TextRange = "wipeb" Then
'shp.Fill.Transparency = 0
'shp.ZOrder msoSendToBack
shp.Fill.Transparency = 0.75
shp.ZOrder msoBringToFront
End If
End If
End If
Next shp
Next sld
End Sub
If you change the order of shapes (as changing the z-order does) or delete them in the midst of a For Each/Next loop, the results won't be what you expect.
If deleting shapes, you can use something like this:
For x = sld.Shapes.Count to 1 Step -1
' delete sld.Shapes(x) if it meets your conditions
Next
If changing the z-order, you may need to collect references to the shapes in an array and step through the array a shape at a time.
Okay, got it! Steve Rindsberg pointed me in the right direction and I corrected the "On Error Resume Next" and now the routines are doing what was expected. Thanks for the help!
Wipe Front():
Sub Wipe_Front()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
wshp.Fill.Transparency = 0.75
wshp.ZOrder msoBringToFront
'wshp.Fill.Transparency = 0
'wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub
Wipe_Back():
Sub Wipe_Back_New()
Dim sld As slide
Dim shp As Shape
Dim str As String
Dim wshps() As Shape, i As Long
ReDim wshps(0 To 1)
i = 0
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoAutoShape Then
If shp.HasTextFrame Then
If shp.TextFrame.TextRange = "wipey" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
If shp.TextFrame.TextRange = "wipeb" Then
Set wshps(i) = shp
i = i + 1
ReDim Preserve wshps(0 To i) As Shape
End If
End If
End If
Next shp
For Each wshp In wshps
On Error Resume Next
'wshp.Fill.Transparency = 0.75
'wshp.ZOrder msoBringToFront
wshp.Fill.Transparency = 0
wshp.ZOrder msoSendToBack
Next wshp
Next sld
End Sub