I would like to create the macro which will format the selected "DATA LABELS" in chart in powerpoint. Below is my code. But the problem is Im not able to write code for selected "Data Labels". Please assist
Sub testSelection2()
Dim shp As Shape
Dim count As Integer
Dim left_count As Double
Dim Selected_Series As Integer
Dim PPoint As Integer
Set shp = ActiveWindow.Selection.ShapeRange(1)
count = shp.Chart.SeriesCollection(1).Points.count
For i = 1 To count
shp.Chart.SeriesCollection(2).Points(i).DataLabel.Format.TextFrame2.TextRange.Font.Size = 12
Next
End Sub
Related
I have put together an e-learning module. I am still very new at vba though. I am trying to make a dynamic main menu which contains multiple text boxes. If the text in a text box matches the title of a slide, that shape should then then be hyperlinked to the corresponding slide. Ideally, the text boxes on the Main Menu would contain the names of Sections and hyperlink to the first slide in the named section, but I couldn't figure that out, so instead I made the title of the first slide in each section match the text. I've searched and searched and gotten as close as I could. I am hoping someone can help me finish it. I have gotten past several errors, and have the text hyperlinked, however all linked take the user to the last slide in the presentation instead of the proper slide. Thank you in advance for any guidance!!
Here is the code:
Sub TestMe()
'Original Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim aSl As Slide 'active slide
Dim dSl As Slide 'destination slide
Dim Slde As Slide
Dim oSh As Shape
Dim aSl_ID As Integer
Dim aSl_Index As Integer
Dim dSl_ID As Integer
Dim dSl_Index As Integer
Dim sTextToFind As String
Dim hypstart As String
Dim Titl As String
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
' Set ActiveSld_Index =
' Set DestinationSld_ID = oSl.SlideID
' Set DestinationSld_Index = oSl.SlideIndex
For Each oSh In aSl.Shapes
'If IsSafeToTouchText(oSh) = True Then
sTextToFind = oSh.TextFrame.TextRange.Text
'loop through slides looking for a title that matches the text box value
On Error Resume Next
Set dSl = FindSlideByTitle(sTextToFind)
' get the information required for the hyperlink
dSl_ID = CStr(dSl.SlideID)
dSl_Index = CStr(dSl.SlideIndex)
' find the text string in the body
hypstart = InStr(1, sTextToFind, sTextToFind, 1)
'make the text a hyperlink
With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
End With
'End If
Next oSh
End Sub
Public Function FindSlideByTitle(sTextToFind As String) As Slide
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
'If .HasTextFrame Then
'If Not .TextFrame.TextRange.Text Is Nothing Then
'myPres.Slides(1).Shapes.Title.TextFrame.TextRange
On Error Resume Next
If UCase(.TextFrame.TextRange.Text) = UCase(sTextToFind) Then
'If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
'End If
End If
'End If
End With
Next
Next
End With
End Function
Public Function IsSafeToTouchText(pShape As Shape) As Boolean
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
On Error GoTo ErrorHandler
If pShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
' Errors here if it's a bogus shape:
If Len(pShape.TextFrame.TextRange.Text) > 0 Then
' it's safe to touch it
IsSafeToTouchText = True
Exit Function
End If ' Length > 0
End If ' HasText
End If ' HasTextFrame
Normal_Exit:
IsSafeToTouchText = False
Exit Function
ErrorHandler:
IsSafeToTouchText = False
Exit Function
End Function
Here is the revised code. I have gone in circles and am now stuck. Any suggestions are much appreciated!
After I restored the original function (FindSlideByTitle), I kept getting an error on got an error on .textframe.textrange, making me think that the type of shape I used on my slide (freeform) needed TextFrame2, so I edited that, which fixed the error, but since then I've not been able to make the hyperlink work and have tried instead to use GoTo Slide by including the parent.
I even tried making an array of all freeform shapes on the slide, but I'm still new at this and perhaps I don't fully understand the concepts yet. As it currently stands, I don't get any errors, however, when I click one of the shapes, the shape's appearance changes from the click, but it doesn't go anywhere.
I have also included an image of the actual slide.
Sub TestLinkShapesToSlideTitles()
Dim aSl, dSl, oSl As Slide 'active slide, destination slide
Dim oSh As PowerPoint.Shape
Dim aSl_ID, dSl_ID As Integer
Dim aSl_Index, dSl_Index As Long
Dim dSl_Title, hypstart, Titl As String
Dim sTextToFind As String
Dim numshapes, numFreeformShapes As Long
Dim FreeformShpArray As Variant
Dim ShpRange As Object
Dim oPres As Presentation
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
''''''''''''''''''''''''''''
'In this section I tried to make an array of all the freeform shapes on the slide, thinking that would help.
With aSl.Shapes
numshapes = .Count
'Continues if there are Freeform shapes on the slide
If numshapes > 1 Then
numFreeformShapes = 0
ReDim FreeformShpArray(1 To numshapes)
For i = 1 To numshapes
'Counts the number of Freeform Shapes on the Slide
If .Item(i).Type = msoFreeformShape Then
numFreeformShapes = numFreeformShapes + 1
FreeformShpArray(numFreeformShapes) = .Item(i).Name
End If
Next
'Adds Freeform Shapes to ShapeRange
If numFreeformShapes > 1 Then
ReDim Preserve FreeformShpArray(1 To numFreeformShapes)
Set ShpRange = .Range(FreeformShpArray)
'asRange.Distribute msoDistributeHorizontally, False
End If
End If
End With
''''''''''''''''''''''''''
On Error Resume Next
'Loop through all the shapes on the active slide
For Each oSh In aSl.Shapes
If oSh.Type = msoFreeform Then 'oSh.Type = 5
'If oSh.HasTextFrame Then
If oSh.TextFrame2.HasText Then 'results in -1
With oSh
sTextToFind = .TextFrame2.TextRange.Characters
'sTextToFind results in "Where to Begin"
'.TextFrame2.TextRange.Characters results in "Learn the Lingo", which is the shape after Where to Begin.
End With
End If
'End If
'If IsSafeToTouchText(oSh) = True Then
'With oSh.TextFrame
'sTextToFind = .TextRange.Characters.Text
'loop through slides looking for a title that matches the text box value
'For Each oSl In ActivePresentation.Slides
'If oSl.Shapes.HasTitle Then
'Titl = Slde.Shapes.Title.TextFrame.TextRange <<<<< I kept getting the error here...
On Error Resume Next
Set dSl = FindSlideByTitle_Original(sTextToFind)
' get the information required for the hyperlink
dSl_Title = dSl.Shapes.Title.TextFrame.TextRange
dSl_ID = dSl.SlideID
dSl_Index = dSl.SlideIndex
With oSh
.ActionSettings(ppMouseClick).Parent.Parent.View.GoToSlide dSl_Index, msoFalse 'Go to slide and don't reset animations
End With
' find the text string in the body
'hypstart = InStr(1, sTextToFind, dSl_Title, 1)
'make the text a hyperlink
'With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
'.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
'End With
'End With
End If
'End If
Next oSh
End Sub
Public Function FindSlideByTitle_Original(sTextToFind As String) As Slide
'Source: https://stackoverflow.com/questions/25038952/vba-powerpoint-select-a-slide-by-name
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle_Original = oSl
End If
End If
End With
Next
End Function
I want to select a range of slides in Powerpoint by vba. For Excel you simply write
Range("A1:A100")
I want to select from slide number 5 to 10, how do I code that? My code just selects two slides:
ActivePresentation.Slides.Range(Array(5,10)).Select
Here is an example. This will depend on which type of Text box you are using. I am assuming standard textbox you select which is a shape. I am using some test textboxes which you would need to adjust to suit your needs.
You call the sub SelectSlides to generate the array of slides numbers for the slides to select between the two text box numbers.
You use the Range method to return any number of shapes or slides.
To specify an array of integers or strings for Index, you can use the Array function or, I believe, pass an array into the Range.
I will be upfront, whilst this worked once, powerpoint the crashed and since then the code has selected only the last item.
However, you can assign ppt.Slides.Range(slidesArray) to a Slides object and work with that e.g.
Dim slidesObject As Slides
Set slidesObject = ppt.Slides.Range(slidesArray)
Code:
Option Explicit
Public Sub SelectSlideArray()
Dim ppt As Presentation
Dim sld As Slide
Dim textBox1 As Shape
Dim textBox2 As Shape
Set ppt = ActivePresentation
Set sld = ppt.Slides(1) ' slide with text boxes in
Set textBox1 = sld.Shapes("TextBox 3") 'change as required
Set textBox2 = sld.Shapes("TextBox 4") 'change as required
textBox1.TextFrame.TextRange = 5 ' you can say TextRange.Text but .Text is defaut
textBox2.TextFrame.TextRange = 10
Dim startSlideNumber As Integer
Dim endSlideNumber As Integer
startSlideNumber = Int(textBox1.TextFrame.TextRange)
endSlideNumber = Int(textBox2.TextFrame.TextRange)
SelectSlides ppt, startSlideNumber, endSlideNumber
'PrintShapeNames sld
End Sub
Public Sub SelectSlides(ByVal ppt As Presentation, ByVal startSlideNumber As Long, ByVal endSlideNumber As Long)
Dim outputSlideNumber As Long
outputSlideNumber = startSlideNumber
If ppt.Slides.Count < endSlideNumber Then
MsgBox "You don't have enough slides in the presentation!"
End
ElseIf endSlideNumber < startSlideNumber Then
MsgBox "End slide is before start slide!"
End
Else
Dim slidesArray()
ReDim slidesArray(0 To endSlideNumber - startSlideNumber)
Dim currentSlide As Long
For currentSlide = LBound(slidesArray) To UBound(slidesArray)
slidesArray(currentSlide) = outputSlideNumber
outputSlideNumber = outputSlideNumber + 1
Next currentSlide
End If
ppt.Slides.Range(slidesArray).Select
End Sub
Private Sub PrintShapeNames(ByVal sld As Slide)
Dim shp As Shape
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
End Sub
I am currently using this code to update all links in my powerpoint presentation:
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next k
End With
Next i
End Sub
Instead of updating the link of every chart in the presentation, is it possible to have this code loop through only selected slides? Or if it's easier - is it possible to set a range? For example, only update charts on slides 15-30?
Thank you!
EDIT:
Resolution provided in comments - here is my revised code
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
Dim sld As Slide
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim shp As Shape
For Each sld In ActivePresentation.Slides.Range(Array(11, 12, 13, 14, 15, 16, 17, 18))
For Each shp In sld.Shapes
On Error Resume Next
shp.LinkFormat.SourceFullName = ExcelFile
If shp.LinkFormat.SourceFullName = ExcelFile Then
shp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next shp
Next
End Sub
Yes you can compose custom ranges on Slides as well as on Shapes, using an Array as the index parameter. Try this:
Dim sld As Slide
For Each sld In ActivePresentation.Slides.Range(Array(1, 3, 5))
Debug.Print sld.Name
Next
Output:
Slide2
Slide4
Slide6
p.s. I had deleted a slide in the test presentation.
Since you also mentioned processing just selected slides, you can do that like so:
Sub SelectedSlides()
Dim osl As Slide
For Each osl In ActiveWindow.Selection.SlideRange
Debug.Print osl.SlideIndex
Next
End Sub
Note that this will give you the selected slides in REVERSE order of selection. That is, if you control-click slides 2,4,6, this will give you 6,4,2.
I would like to make an array (Set Selected_slds = ActivePresentation.Slides.Range) of slides. The slides are to be part of an array that can be selected from a number of Check boxes. So, the idea of the code I would like to write is:
Dim k As Integer
Dim list_of_slides As Array
Dim Selected_slds As SlideRange
For k = 1 To Count(CheckBoxs)
If CheckBox(k) = True Then
add.slide(k) to list_of_slides
End If
Next
Set Selected_slds = list_of_slides
The above is part of a longer code, where Selected_slds is used.
What I have done so far is this:
Sub Test()
Dim oSh As Shape
Dim oSl As Slide
Dim k As Integer
' Look at each shape on each slide in the active pres
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' Is the shape a control?
If oSh.Type = msoOLEControlObject Then
' Is it a checkbox?
If InStr(UCase(oSh.OLEFormat.ProgID), "FORMS.CHECKBOX") > 0 Then
' BINGO, found what we're after, so ...
If oSh.OLEFormat.Object.Value = True Then
MsgBox "Checked"
ElseIf oSh.OLEFormat.Object.Value = False Then
MsgBox "Uncheked"
End If
End If
End If
Next ' Shape
Next ' Slide
End Sub
Which works, but I am not sure what to do, to get it to do what I am looking for. It is coded in power point.
In word I'm using the following to insert a text from an input box in a designated area in word:
Sub OpenWord()
Dim var1 As String
var1 = InputBox("vul!")
Documents.Open ("C:\Documents and Settings\aa471714\Desktop\TEMP BESTANDEN/Doc2.doc")
ActiveDocument.Bookmarks("Test").Select
Selection.Text = var1
End Sub
I know would like to create to same function for something in powerpoint. So what I did in word (classifying a bookmark area in word as "test" and then fill in a variable there) in want to do in powerpoint as well. Define an object in some way so I can fill in a variable there.
Anybody a clue on how I have to do this in PPT?
Here's the basics of what you need.
Sub WriteToTextBox()
Dim tb As Shape
Dim sld As Slide
Dim pres As Presentation
Dim var1 As String
var1 = InputBox("Var1")
Set pres = ActivePresentation
Set sld = pres.Slides(23) 'Modify as needed
Set tb = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 50) 'Modify dimensions as needed
tb.name = "unique name" '< assign a unique name to the textbox so you can refer to it later
tb.TextFrame.TextRange.Text = var1
End Sub
Sub ReadFromTextBox()
Dim s$
Dim sld As Slide
Dim pres As Presentation
Set pres = ActivePresentation
Set sld = pres.Slides(23) 'Modify as needed
s = sld.Shapes("unique name").TextFrame.TextRange.Text 'Read the value from the textbox
MsgBox s
End Sub