PowerPoint vba group shapes using Shape objects, not shape names - vba

I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA

Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub

Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub

Related

Edit a the text in a Shape(textbox) that is placed somewhere on a Word Doc VBA

I'm trying to create a way for a word document to have certain textfields data to be replaced with other data. In my case, textfields are shown as a part of shapes and the textfields themselves don't have name's to them so I wanted to possibly do it by their shape ID. So for example I have a 5 Textboxes next to each other and say I want to edit the 4th textbox to say something since it's blank without affecting the other textboxes. What would I need to do?
Though Process: Because all the files have the same format, if I can figure out the id of that shape or textbox, I can directly reference that id and change the textfield that way. The text in the field is all random so I can't do a specific find word and replace so that's why I'm trying to do it by id or even just by having it do a count of the number of shapes on the page of a word document.
Tip: I turned on paragraph markers to see the textboxes more clearly.
Example of Code I've written so far:
Sub TextBox()
'find a specific textbox and edit it
Dim doc As word.Document, rng As word.Range
Dim shp As Shape, iShp As word.InlineShape
Set doc = ActiveDocument
Dim textbCount As String
Dim textbId As String
'textbCount = ActiveDocument.Shapes.Count
'textbId = oShape.ID
Dim sr As ShapeRange
Set sr = shp.TextFrame.TextRange.ShapeRange(5)
For Each shp In sr
If shp.ID = 0 Then
'oShape.TextFrame.TextRange.InsertAfter shp.ID
'shp.Delete
Debug.Print shp.Type
Debug.Print shp.ID
End If
Next shp
If ActiveDocument.Shapes.Count > 0 Then
For Each shp In ActiveDocument.Shapes
If shp.AutoShapeType = msoShapeRectangle Then
If shp.TextFrame.HasText = True Then
'shp.TextFrame.TextRange.GoToNext (wdGoToField)
'shp.Delete
'shp.Delete
shp.TextFrame.TextRange.InsertAfter textbCount
Exit For
End If
End If
Next shp
End If
End Sub
This is code you could use, I was able to just figure out the answer. What the code does is checks that the word document that you are trying to read is open and then it first checks to see if there are any shapes at all on the document which is the c > 0 because textboxes are categorized as shapes. Then it does a For Each loop going through all the shapes on the entire document and each shape has it's own unique identifier.
I already tested this for if templates that have the same format of textboxes, they will typically share the same identifier, so if you say have 2 word documents with each 20 textboxes and its a carbon copy of the other just with different text in the boxes almost like they took this blank document and then used it as the base template, it's highly likely that the ID's between the 2 documents are the same if opened separately, if they are combined into 1 document is when the ID's will change so that your not referencing the same data.
To continue on with the code, it will next check all the textboxes for a #, this can be changed out for anything, but for my case I wanted to find out which boxes by their ID I would be using since the word doc won't tell you, so because no where else on the document had #'s, I used those to find where the boxes were. Once you know the ID, you can just reference the boxes directly instead of using the #'s but you need to first know which ones have them.
Next the code will print to the "Immediate Window" which is like a debug window that you can open either in the view tab or by ctrl + G if your one windows and what it will print is the shape ID for each shape that has the # and then print whatever text is in that box which should include the # there along with whatever text is there in that box.
Now if you want to add text to the text box, I didn't include it in my example, or even replace the text. Just make an if statement for if shp.ID = 16 for example then inside that If Then statement say shp.TextFrame.TextRange.Text = "" or if you have a string you want to pass in, replace "" with whatever string that is and in the double quotes you can either leave that blank to make that textbox your referencing blank or you can put text in it to make it say something.
If your doing a project, like I was, and it requires checking a lot of these textboxes to reference the string to another textbox so basically one textbox determines the other. Use For Each shp In oShp a lot or your equivalent to that and check each ID and store it in a string variable and then do a separate For Each to reference those string variables to make new if statements or declarations since you you'll need to go through all the textboxes at least once to grab whatever data might be contained in them since it goes through the For Each sequence one at a time.
Dim shp As Shape
Dim oShp As Object
Dim doc As Document
Dim c As Integer
Dim objWord As Object
Dim objDoc As Document
'Set doc = ActiveDocument
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Open("C:\Users\word.docx") 'Set this to wherever the word file is located along with the name of the word file so "C:\Users\worddoc.docx" is an example you could do
'Set objDoc = objWord.ActiveDocument
Set doc = objWord.ActiveDocument
Set oShp = doc.Shapes
c = ActiveDocument.Shapes.Count
'Set text1 = shp.TextFrame.TextRange
If c > 0 Then
For Each shp In oShp
If InStr(shp.TextFrame.TextRange.Text, "#") Then
Debug.Print shp.ID
Debug.Print shp.TextFrame.TextRange.Text
End If
Next shp
Debug.Print c
End If

Changing colour of text segments in a powerpoint presentation

I have a Powerpoint-Slide with pasted, formatted source code in the form of text shapes. Sadly the contrast of some part of that text is bad on a projector, so I would like to change every colour occurence for a specific font with a different colour. In this specific example I want to replace the orange colour:
Iterating over all shapes and accessing the whole text of a shape is not a problem, but I can't find any property that allows me to enumerate over the styled text segments:
Sub ChangeSourceColours()
For Each pptSlide In Application.ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If (pptShape.Type = 1) And (pptShape.TextFrame.TextRange.Font.Name = "Consolas") Then
' Iterate over styled segments and change them if the previous colour is orangey
MsgBox pptShape.TextFrame.TextRange
End If
Next
Next
End Sub
The TextRange2 property looked helpful at a first glance, but looking at the variables in the debugger I see nothing that looks like a series of formatted segments. I would expect to find something like <span> in HTML to check and possibly change the colour.
The textFrame2.textRange.Font is valid for the whole text. If you want to access the single characters and their individual formatting, you need to access textRange.Characters.
The following routine changes the text color for all characters that have a specific color to a new color:
Sub ChangeTextColor(sh As Shape, fromColor As Long, toColor As Long)
Dim i As Long
With sh.TextFrame2.TextRange
For i = 1 To .Characters.Length
If .Characters(i).Font.Fill.ForeColor.RGB = fromColor Then
.Characters(i).Font.Fill.ForeColor.RGB = toColor
End If
Next i
End With
End Sub
You call it from your code with
Dim pptSlide as Slide
For Each pptSlide In Application.ActivePresentation.Slides
Dim pptShape As Shape
For Each pptShape In pptSlide.Shapes
If (pptShape.Type = 1) And (pptShape.TextFrame.TextRange.Font.Name = "Consolas") Then
ChangeTextColor pptShape, RGB(255, 192, 0), vbRed
End If
Next
Next
You will have to adapt the RGB-Code to the orange you are using, or instead of using RGB, you can use ObjectThemeColor. To avoid a type mismatch, you need to declare the pptShape variable as Shape - you should declare all your variables and use Option Explicit anyhow.
Note that you can use the ChangeTextColor-routine also in Excel (and probably also in Word). Shapes are defined similar in Excel and Powerpoint. Advantage in Excel: You can use the macro recorder to get some insights how a Shape can be used in Office VBA.

Visio VBA: How to make all text in Org Chart Bold

I would like to simplify updating my orgcharts in Visio. So far I have a macro borrowed from here https://bvisual.net/2010/01/28/applying-selected-datagraphic-to-the-whole-document/ and written out below. I would like to adapt it to make some changes to the format of the text withing shapes e.g. to make the font bold and potentially to change it's colour. I'm finding it really difficult to find examples of this online so any help/suggestion would be greatly appreciated.
Public Sub ApplyDataGraphicToDocument()
Dim mstDG As Visio.Master
Dim shp As Visio.Shape
Dim pag As Visio.Page
Dim firstProp As String
If Visio.ActiveWindow.Selection.Count = 0 Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
Set shp = Visio.ActiveWindow.Selection.PrimaryItem
If shp.DataGraphic Is Nothing Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
'Get the shapes DataGraphic master
Set mstDG = shp.DataGraphic
'Get the name of the first Shape Data row
firstProp = "Prop." & _
shp.CellsSRC(Visio.visSectionProp, 0, 0).RowNameU
End If
End If
For Each pag In Visio.ActiveDocument.Pages
If pag.Type = visTypeForeground Then
For Each shp In pag.Shapes
'Check that the named Shape Data row exists
If shp.CellExistsU(firstProp, Visio.visExistsAnywhere) Then
'Set the DataGraphic
shp.DataGraphic = mstDG
End If
Next
End If
Next
End Sub
You can modify the default OrgChart shapes, although it is not officially supported. To change the default shapes (make their font bold), you'll need to edit the templates (masters) for those OrgChart shapes. In the same blog you can find more information on customizing the OrgChart diagrams, here: https://bvisual.net/2012/05/08/creating-a-custom-org-chart-template-with-extra-properties
The procedure is mostly the same, just instead of adding the properties, you make the text bold.

Create animated random image display tool in VBA

I have a PowerPoint slide with different images. I need to create VBA code in PowerPoint that recognises all these images and fades them out one by one - except for one randomly chosen image. This last image should remain until the end, then fade out and display in the middle of the slide.
I have an idea of how to do it and have experience with object oriented languages (R) but I have never used VBA before. Therefore I would be grateful for pointers on how to do any of the following in VBA:
Determine number of images on active slide
Select each image one after another and assign a counter variable as selection label (that part should work as described here)
Create "Range A" of all assigned counter variables
Select random number "x" in "Range A"
Create "Range B" of all counter variables in "Range A" EXCEPT for the random number "x"
Randomise the order of variables in "Range B"
Loop through "Range B" and fade out images whose label corresponds to the respective "Range B" variable that comes up
Fade out the image whose label corresponds to "x"
Insert the image whose label corresponds to "x" in the centre of the slide
If it is very difficult to recognise images or assign labels to those images I can also do so manually. However, it would be nicer if that could happen automatically. I would be grateful for any pointers, also in the form of links if you think that part of the above process is already described somewhere else (I'm afraid since I'm inexperienced in VBA I am not using very effective search terms).
EDIT:
Please find the solution (steps 8 and 9 are still missing)
Sub SelectionMacro()
Dim oSl As Slide
Dim oSh As Shape
Dim aArrayOfShapes() As Variant
Dim ShapeX As Shape
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim FadeEffect As Effect
Set oSl = ActivePresentation.SlideS(1)
'This section creates an array of all pictures on Slide1 called
'"aArrayOfShapes"
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes) + 1)
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next
'This section creates a random index number within the bounds of the
'length of aArrayOfShapes and assigns the shape with that index number
'to the Shape object ShapeX
Randomize
NumberX = Int((UBound(aArrayOfShapes) - (LBound(aArrayOfShapes) - 1)) * Rnd) + LBound(aArrayOfShapes)
Set ShapeX = aArrayOfShapes(NumberX)
'This section shuffles aArrayOfShapes
For N = LBound(aArrayOfShapes) To UBound(aArrayOfShapes)
J = CLng(((UBound(aArrayOfShapes) - N) * Rnd) + N)
If N <> J Then
Set Temp = aArrayOfShapes(N)
Set aArrayOfShapes(N) = aArrayOfShapes(J)
Set aArrayOfShapes(J) = Temp
End If
Next N
'This section loops through all Shapes in aArrayOfShapes and
'fades them out one by one EXCEPT for ShapeX
For Each Shape In aArrayOfShapes
If ShapeX.Name <> Shape.Name Then
Set FadeEffect = oSl.TimeLine.MainSequence.AddEffect _
(Shape:=Shape, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerAfterPrevious)
With FadeEffect
.Timing.Duration = 0.5
.Exit = msoTrue
End With
End If
Next Shape
End Sub
In order to reset the slide to the state before running the macro (so as to be able to run it again and display another random image) the following macro needs to be run:
Sub ResetSelection()
For i = ActivePresentation.SlideS(1).TimeLine.MainSequence.Count To 1 Step -1
ActivePresentation.SlideS(1).TimeLine.MainSequence(i).Delete
Next i
End Sub
Working out the range of images shouldn't be too hard. This'll get you started.
Assigning animation to shapes can be tricky. You might be better off duplicating the slide with all the images then deleting all but a randomly chosen image.
Dim oSl As Slide
Dim oSh As Shape
' Dynamic array of shapes to hold shape references
Dim aArrayOfShapes() As Shape
Set oSl = ActiveWindow.Selection.SlideRange(1)
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes))
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next`enter code here`
' Now you have an array containing references to all the pictures
' on the slide. You can use a random number function to return
' an index into the array to choose a picture at random.
With aArrayOfShapes(RandomNumberFunction(LBound(aArrayOfShapes), UBound(aArrayOfShapes)))
' google to find an appropriate function; they're out there
' do whatever you need to do with your shapes here
End With

Powerpoint VBA Make duplicated shape view active to select for grouping

I have a library of eight images on my PowerPoint slide. Based on a userform input, some of the components get duplicated and renamed by adding a "1" or "2" after the original image's name so that they are differentiable. I then want to group the new images (I am building up an item from the component images). I am able to duplicate the images and line them up correctly, but I am having trouble grouping them. Note that I am not always grouping the same number of items, it is dependent on user inputs.
I receive the error "Shape (unknown member): Invalid request. To select a shape, its view must be active."
I searched and attempted to implement several strategies from the help forums but am coming up empty.
PLEASE HELP!!!
-Kevin
Part of code below because it is very long, but this is where my first problem arises:
Dim Cargo As Shape, Cargo_Dup as Shape, Chemical as Shape, Chemical_Dup as Shape
Set Cargo = ActivePresentation.Slides(2).Shapes("Cargo")
Set Chemical = ActivePresentation.Slides(2).Shapes("Chemical")
Cargo.Name = "Cargo"
Chemical.Name = "Chemical"
With ActivePresentation
Set Cargo_Dup = ActivePresentation.Slides(2).Shapes("Cargo")
With Cargo_Dup.Duplicate
.Name = "Cargo_1st"
.Left = 0
.Top = 540
End With
'CHEMICAL
If Input1 = "Chemical" Then
Set Chemical_Dup = ActivePresentation.Slides(2).Shapes("Chemical")
With Chemical_Dup.Duplicate
.Name = "Chemical" & 1
.Left = 36.74352
.Top = 540 + 0.36
End With
'''''WHERE PROBLEM ARISES'''''
ActivePresentation.Slides(2).Shapes("Cargo_1st").Select
ActivePresentation.Slides(2).Shapes("Chemical1").Select msoFalse
Set Vehicle = ActiveWindow.Selection.ShapeRange.Group
Vehicle.Name = "Vehicle"
'Elseif with a bunch for options where addition grouping occurs
I need some kind of keyboard macro to type this for me:
Never select anything unless you absolutely have to.
You nearly never absolutely have to.
You're asking how to make a view active so that you can select something.
I figure that's the wrong question.
It's more useful to know how to work with shapes WITHOUT having to select them.
Grouping shapes w/o selecting them is a bit tricky, but it can be done.
Here's an example of how you might go about this:
Sub GroupWithoutSelecting()
Dim oSl As Slide
Dim oSh As Shape
Dim aShapes() As String
Set oSl = ActivePresentation.Slides(2) ' or whichever slide you like
ReDim aShapes(1 To 1)
With oSl
For Each oSh In .Shapes
If oSh.Type <> msoPlaceholder Then ' can't group placeholders
' Substitute the real condition you want to use
' for selecting shapes to be grouped here
If oSh.Type = msoAutoShape Then
' add it to the array
aShapes(UBound(aShapes)) = oSh.Name
ReDim Preserve aShapes(1 To UBound(aShapes) + 1)
End If
End If
Next
' eliminate the last (empty) element in the array
ReDim Preserve aShapes(1 To UBound(aShapes) - 1)
' Create a shaperange from the array members and group the shaperange
.Shapes.Range(aShapes).Group
End With ' oSl
End Sub