I want to create a VBA macro in PPT to Group shapes in same height across multiple rows in Powerpoint using VBA. My initial step would be ideally like this image:
Group Textboxes row wise
There is a matrix of textboxes in many rows and columns evenly distributed vertically & horizontally. I want to select all the shapes altogether and run a macro to group the textboxes row wise, into multiple rows. Code below is copied and not final yet, Appreciate any help, snippets for this, thanks a lot.
Sub GroupSameHeightObjects()
' Dimension the variables.
Dim shapeObject As shape
Dim lSlideNumber As Long
Dim strPrompt, strTitle As String
Dim ShapeList() As String
Dim count As Long
' Initialize the counter.
count = 0
' Make sure PowerPoint is in slide view.
If ActiveWindow.ViewType <> ppViewSlide Then
' Set up the error message.
strPrompt = "You must be in slide view to run this macro." _
& " Change to slide view and run the macro again."
strTitle = "Not In Slide View"
' Display the error message.
MsgBox strPrompt, vbExclamation, strTitle
' Stop the macro.
End
End If
' Get the current slide number.
lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
' Loop through the shapes on the slide.
For Each shapeObject In _
ActivePresentation.Slides(lSlideNumber).Shapes
' See whether shape is a placeholder.
If shapeObject.Type <> msoPlaceholder Then
' Increment count if the shape is not a placeholder.
count = count + 1
' Get the name of the shape and store it in the ShapeList
' array.
ReDim Preserve ShapeList(1 To count)
ShapeList(count) = shapeObject.Name
End If
Next shapeObject
' If more than 1 object (excluding a placeholder object) is found,
' group the objects.
If count > 1 Then
With ActivePresentation.Slides(lSlideNumber).Shapes
' Group the shapes together.
.Range(ShapeList()).Group.Select
End With
Else
Select Case count
' One shape found.
Case 1
' Set up the message.
strPrompt = "Only one shape found." _
& " You need at least two shapes to group."
strTitle = "One Shape Available"
' Zero shapes found.
Case 0
' Set up the message.
strPrompt = "No shapes found. You need to have at " _
& "least two shapes, excluding placeholders."
strTitle = "No Shapes Available"
' An error occurred.
Case Else
' Set up the message.
strPrompt = "The macro found an error it could not correct."
strTitle = "Error"
End Select
' Display the message.
MsgBox strPrompt, vbExclamation, strTitle
End If
End Sub
I don't have time right now to write/test any code, but if I had to do this, I'd start with something like this snippet I had from another project:
Sub GroupCertainShapes()
Dim x As Long
Dim sTemp As String
Dim aShapeList() As String
Dim lShapeCount As Long
With ActivePresentation.Slides(1)
' iterate through all shapes on the slide
' to get a count of shapes that meet our condition
For x = 1 To .Shapes.Count
' Does the shape meet our condition? count it.
If .Shapes(x).Type = msoAutoShape Then
lShapeCount = lShapeCount + 1
End If
Next
' now we know how many elements to include in our array,
' so redim it:
ReDim aShapeList(1 To lShapeCount)
' Reset the shape counter
lShapeCount = 0
' Now add the shapes that meet our condition
' to the array:
For x = 1 To .Shapes.Count
' apply some criterion for including the shape or not
If .Shapes(x).Type = msoAutoShape Then
lShapeCount = lShapeCount + 1
aShapeList(lShapeCount) = .Shapes(x).Name
End If
Next
' and finally form a group from the shapes in the array:
If UBound(aShapeList) > 0 Then
.Shapes.Range(aShapeList).Group
End If
End With
End Sub
A couple of things that may not give you fully what you're after but that'll save you some trouble down the line:
Sub GroupSameHeightObjects()
' Dimension the variables.
Dim shapeObject As shape
Dim lSlideNumber As Long
' This will dim strPrompt as a variant
' Dim strPrompt, strTitle As String
Dim strPrompt as string, strTitle as string
Dim ShapeList() As String
Dim count As Long
' Initialize the counter.
count = 0
' Make sure PowerPoint is in slide view.
If ActiveWindow.ViewType <> ppViewSlide Then
' Set up the error message.
strPrompt = "You must be in slide view to run this macro." _
& " Change to slide view and run the macro again."
strTitle = "Not In Slide View"
' Display the error message.
MsgBox strPrompt, vbExclamation, strTitle
' Stop the macro.
' See previous comment
'End
Exit Sub
End If
' Get the current slide number.
' Nope, you want the SlideIndex; SlideNumber gives you the number that'll
' appear when you use PPT's slide numbering features; if the user sets the
' starting number to something other than 1, your code will break
'lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
lSlideNumber = ActiveWindow.Selection.SlideRange.SlideIndex
' Loop through the shapes on the slide.
For Each shapeObject In _
ActivePresentation.Slides(lSlideNumber).Shapes
' See whether shape is a placeholder.
If shapeObject.Type <> msoPlaceholder Then
' Increment count if the shape is not a placeholder.
count = count + 1
' Get the name of the shape and store it in the ShapeList
' array.
' I've learned not to trust shape names in PPT
' I'd dim ShapeList as an array of shapes and then
' Set ShapeList(count) = shapeObject
ReDim Preserve ShapeList(1 To count)
ShapeList(count) = shapeObject.Name
End If
Next shapeObject
' You could include this next bit in the following Case selector,
' Case > 1 ... etc.
' If more than 1 object (excluding a placeholder object) is found,
' group the objects.
If count > 1 Then
With ActivePresentation.Slides(lSlideNumber).Shapes
' Group the shapes together.
.Range(ShapeList()).Group.Select
End With
Else
Select Case count
' One shape found.
Case 1
' Set up the message.
strPrompt = "Only one shape found." _
& " You need at least two shapes to group."
strTitle = "One Shape Available"
' Zero shapes found.
Case 0
' Set up the message.
strPrompt = "No shapes found. You need to have at " _
& "least two shapes, excluding placeholders."
strTitle = "No Shapes Available"
' An error occurred.
Case Else
' Set up the message.
strPrompt = "The macro found an error it could not correct."
strTitle = "Error"
End Select
' Display the message.
MsgBox strPrompt, vbExclamation, strTitle
End If
End Sub
Related
I took this code directly from the VBA documentation from Microsoft, I am trying to select a shape then iterate through outgoing connected shapes.
Public Sub ConnectedShapes_Outgoing_Example()
' Get the shapes that are connected to the selected shape
' by outgoing connectors.
Dim vsoShape As Visio.Shape
Dim lngShapeIDs() As Long
Dim intCount As Integer
If ActiveWindow.Selection.Count = 0 Then
MsgBox ("Please select a shape that has connections")
Exit Sub
Else
Set vsoShape = ActiveWindow.Selection(1)
End If
lngShapeIDs = vsoShape.ConnectedShapes _
(visConnectedShapesOutgoingNodes, "")
Debug.Print "Shapes at the end of outgoing connectors:"
For intCount = 0 To UBound(lngShapeIDs)
Debug.Print ActivePage.Shapes(lngShapeIDs(intCount)).Name
Next
End Sub
lngShapeIDs array gives me one item with an ID of 1077.
Then this:
Debug.Print ActivePage.Shapes(lngShapeIDs(intCount)).Name
...gives me an "Invalid Sheet Identifier" error, as if the ID doesn't exist.
The Shapes collection takes an index rather than an ID.
You need Shapes.ItemFromId
I want to write VBA code for inserting the image as per the slide name from the folder means after running the VBA it automatically inserts the images as per the slide name
For eg: if the slide contains "Top View" in the text box then by running the VBA script it should automatically pick the picture having name "Top View" from the particular folder.
As shown in the attached images.
Slide having by text box as top view
Folder Path
I have posted one of the question some days ago but I didn't find the exact solution here is the link of my previous question which I have asked
Previous question
One of member has shared one code but its working properly also I modified it little bit though its not working properly if possible pl. help me
Option Explicit
Sub image_insert()
Dim objPresentaion As Presentation
Dim objSlide As Slide
Dim objImageBox As Shape
Dim sSlideTitle As String
Dim sFolder As String
Set objPresentaion = ActivePresentation
sFolder = "C:\Users\mehta\Desktop\Folder for ppt images\Top
View.jpg"
For Each objSlide In objPresentaion.Slides
sSlideTitle = GetTitleText(objSlide)
' WAS there a title on the slide?
If Len(sSlideTitle) > 0 Then
' make sure the image exists
If Len(Dir$(sFolder & sSlideTitle & ".JPG")) > 0 Then
Set objImageBox = objSlide.Shapes.AddPicture(sFolder &
sSlideTitle & ".JPG", _
msoCTrue, msoCTrue, 25, 25)
Else
' Comment this out later
' MsgBox "Image missing: " & sSlideTitle
End If
Else
' comment this out later:
MsgBox "This slide has no title"
End If
Next ' Slide
End Sub
Function GetTitleText(oSl As Slide) As String
Dim sTemp As String
With oSl
' handle errors in case there's no slide title
On Error Resume Next
sTemp = .Shapes.Title.TextFrame.TextRange.Text
If Err.Number <> 0 Then
sTemp = ""
End If
End With
GetTitleText = sTemp
End Function
Regards.
I have created a macro in Powerpoint that will search for slides that are using a textbox for their title and are replacing them with a Title box. The steps are
1) find the slides that have a textbox in the title area
2) Copy the text in the textbox to a variable called slTitle.
3) Delete the texbox
4) Create a Title Holder for the current slide
5) Copy the text into the Title holder
6) Move on to the next slide
My macro currently is able to get as far as step 4 but I can't figure out how to get the text in slTitle into the Title box. This should be fairly easy to do but I've tried several ways and nothing seems to work. If anyone can help me figure out this step it would be much appreciated.
I am getting a compile error "Invalid Qualifier" on the line:
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
Here is my current macro.
Sub AddMiMissingTitles()
Dim shpCurrShape As Object
Dim x As Integer
Dim sl As PowerPoint.Slide
Dim sld As Slide
Dim ctr As Integer
Dim s As Shape
'x = ActivePresentation.Slides.Count
'counter ctr used to count number of slides that needed titles added
ctr = 0
'**************************************************************
Set sourcePres = ActivePresentation
x = 1 ' slide counter
'get the title text
For Each sl In sourcePres.Slides
'delete all the empty title text boxes first
For Each s In sl.Shapes
If s.Top < 45 Then ' it's in the title area
'MsgBox s.PlaceholderFormat.Type
If s.Type <> ppPlaceholderTitle Then ' it isn't a proper Title placeholder
If s.HasTextFrame = msoTrue Then
If Trim(s.TextFrame.TextRange.Text) = "" Then
s.Delete ' delete empty text holders
Else
slTitle = s.TextFrame.TextRange.Text
s.Delete
sl.CustomLayout = sl.CustomLayout 'reset the slide
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
End If
End If
End If
End If
Next
'Is there a title placeholder on the current layout?
If sl.CustomLayout.Shapes.HasTitle Then
lngType = sl.CustomLayout.Shapes.Title.PlaceholderFormat.Type
'*********************************
' With ActivePresentation.Slides()
End If
Next
MsgBox "Done! " & vbCrLf & ctr & " Slides needed Titles."
'*********************************
'sl.Shapes.AddPlaceholder lngType
sl.Shapes.Title.TextFrame.TextRange = slTitle
End Sub
I am looking for a solution to select some slides and cut or copy and paste at another location while keeping the section information.
I have seen PPT does not support it out of the box (see http://answers.microsoft.com/en-us/office/forum/office_2013_release-powerpoint/copying-sections-to-a-new-powerpoint/2c723b0d-d465-4ab6-b127-6fdfc195478c?db=5)
and also some VBA Script examples here Exporting PowerPoint sections into separate files
PPTalchemy provides some Add-In but unfortunately the code is not available. See here http://www.pptalchemy.co.uk/powerpoint_hints_and_tips_tutorials.html#2010
Moreover it does not suit to move sections easily within the same presentation.
Any idea how to do this?
Many thanks.
Thierry
To move a section within a presentation, including all slides within the section, call this procedure with the index of the section to be moved and it's new location:
Option Explicit
' ********************************************************************************
' VBA Macro for PowerPoint, written by Jamie Garroch of http://YOUpresent.co.uk/
' ********************************************************************************
' Purpose : Moves a specified section of slides to a new section location
' Inputs : lSectionIndex - the index of the section to be moved
' lNewPosition - the index of the position to move to
' Outputs : None.
' ********************************************************************************
Public Sub MoveSection(lSectionIndex As Long, lNewPosition As Long)
On Error GoTo errorhandler
With ActivePresentation
.SectionProperties.Move lSectionIndex, lNewPosition
End With
Exit Sub
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Sub
This is finally the code I use to move multiple sections selected by slides:
Sub MoveSelectedSections()
' Slides are copied ready to be pasted
Dim lngNewPosition As Long
'Debug.Print ""
'Debug.Print "###Move Sections..."
lngNewPosition = InputBox("Enter a destination section index:")
lngNewPosition = CInt(lngNewPosition) ' Convert String to Int
Call MoveSectionsSelectedBySlides(ActivePresentation, lngNewPosition)
End Sub
Function MoveSectionsSelectedBySlides(oPres As Presentation, lNewPosition As Long)
On Error GoTo errorhandler
' Activate input presentation
oPres.Windows(1).Activate
' Get Selected Sections Indexes
' http://www.thespreadsheetguru.com/the-code-vault/2014/4/3/copy-selected-slides-into-new-powerpoint-presentation
Dim i, cnt As Integer
Dim SelectedSlides As SlideRange
Dim SectionIndexes() As Long
If ActiveWindow.Selection.Type <> ppSelectionSlides Then
MsgBox "No slides selected"
Exit Function
End If
Set SelectedSlides = ActiveWindow.Selection.SlideRange
' selection order is reverse see http://www.pptfaq.com/FAQ00869_Create_a_custom_show_from_current_slide_selection_using_VBA.htm
'Fill an array with sectionIndex numbers
ReDim SectionIndexes(1 To SelectedSlides.Count)
cnt = 0
For i = 1 To SelectedSlides.Count
' Check if already present in array
If Not Contains(SectionIndexes, SelectedSlides(i).sectionIndex) Then
cnt = cnt + 1
SectionIndexes(cnt) = SelectedSlides(i).sectionIndex
End If
Next i
ReDim Preserve SectionIndexes(1 To cnt)
' Move Sections to lNewPosition, first last
For i = 1 To cnt
With oPres
.SectionProperties.Move SectionIndexes(i), lNewPosition
End With
Debug.Print "Section #" & SectionIndexes(i) & " moved to " & lNewPosition
Next i
Exit Function
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Function
Function Contains(arr, v) As Boolean
' http://stackoverflow.com/a/18769246/2043349
Dim rv As Boolean, i As Long ' Default value of boolean is False
For i = LBound(arr) To UBound(arr)
If arr(i) = v Then
rv = True
Exit For
End If
Next i
Contains = rv
End Function
I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub