Solved Using Access VBA to change a Powerpoint text box value (2 Viewers)

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
Good afternoon,

I am trying to have my Access database open up a Powerpoint presentation template .pptx and replace a value with a value from the database. Currently, on the main slide and a few others in the template, we have a placeholder of "XXXXX" for the company name. That value is already part of the database, so I'd like to replace all instances of XXXXX with the value of Me.Company_Name from my Reports form button. I have the following code so far that lets me choose the template from a location, and it tries to cycle through all of the slides looking for that value, but I keep getting an "Object Required" error where I try to start looping through the slides.



Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object
 
Set fdg = Application.FileDialog(msoFileDialogFilePicker)
 
Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")
 
With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           With AppPPT.Presentations.Open(strSelectedItem)
'Here is where I get the error on the following line
               For Each Slide In Presentation.Slides
           For Each Shape In pptSlide.Shapes
            If Shape.Type = TextFrame Then
               TextFrame.TextRange.Text = Replace(TextFrame.TextRange.Text, "XXXXX", "Company Name")
            End If
           Next
        Next
       End With
           'AppPPT.Quit
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
Set AppPPT = Nothing
Set objSFolders = Nothing

I know it's clunky, but I need this to work and I don't remember how to call the Powerpoint slide and textbox... HELP!!
 

Minty

AWF VIP
Local time
Today, 21:59
Joined
Jul 26, 2013
Messages
10,355
I use this to replace a string assuming you already have the object set (in my case ppres is the already open presentation)
SQL:
Sub SetReplaceString(sRepWord As String)

    Dim sld As Slide
    Dim shp As Shape
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    Dim FindWord As Variant
    Dim ReplaceWord As Variant
    Dim iWords As Integer
    Dim textLoc As PowerPoint.TextRange

    FindWord = "xxxxxxx"
    ReplaceWord = sRepWord

    'Loop through each slide in Presentation
 
    For Each sld In ppPres.Slides
    
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    Set textLoc = shp.TextFrame.TextRange.Find(FindWord)  'use Find function to get the textrange for the string being searched for
                    If Not (textLoc Is Nothing) Then 'if something is found
                        textLoc.Text = ReplaceWord      'then replace it
                        iWords = iWords + 1
                    End If
                End If
            End If
        Next shp
      
    Next sld
    Debug.Print "xxxxxxx updated to " & sRepWord & " " & iWords & " times"

End Sub
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
I use this to replace a string assuming you already have the object set (in my case ppres is the already open presentation)
SQL:
Sub SetReplaceString(sRepWord As String)

    Dim sld As Slide
    Dim shp As Shape
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    Dim FindWord As Variant
    Dim ReplaceWord As Variant
    Dim iWords As Integer
    Dim textLoc As PowerPoint.TextRange

    FindWord = "xxxxxxx"
    ReplaceWord = sRepWord

    'Loop through each slide in Presentation

    For Each sld In ppPres.Slides
   
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    Set textLoc = shp.TextFrame.TextRange.Find(FindWord)  'use Find function to get the textrange for the string being searched for
                    If Not (textLoc Is Nothing) Then 'if something is found
                        textLoc.Text = ReplaceWord      'then replace it
                        iWords = iWords + 1
                    End If
                End If
            End If
        Next shp
     
    Next sld
    Debug.Print "xxxxxxx updated to " & sRepWord & " " & iWords & " times"

End Sub


I'm getting "Object doesn't Support this property or method" at

For Each sld In AppPPT.Slides


I'm just using this code from an "On Click" event, not as a separate Sub.
 

bastanu

AWF VIP
Local time
Today, 14:59
Joined
Apr 13, 2010
Messages
1,401
Can you post the full code you have right now? In the first attempt you didn't have Slide declared anywhere.

Cheers,
 

Isaac

Lifelong Learner
Local time
Today, 14:59
Joined
Mar 14, 2017
Messages
8,738
Does this work?

Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide as object, objShape as object, objPresentation as object
 
Set fdg = Application.FileDialog(msoFileDialogFilePicker)
 
Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")
 
With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each objShape In pptSlide.Shapes
                        If Shape.Type = TextFrame Then
                               TextFrame.TextRange.Text = Replace(TextFrame.TextRange.Text, "XXXXX", "Company Name")
                        End If
                       Next objShape
                Next objSlide

           'AppPPT.Quit
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
Set AppPPT = Nothing
Set objSFolders = Nothing
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
Does this work?

Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide as object, objShape as object, objPresentation as object

Set fdg = Application.FileDialog(msoFileDialogFilePicker)

Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")

With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each objShape In pptSlide.Shapes
                        If Shape.Type = TextFrame Then
                               TextFrame.TextRange.Text = Replace(TextFrame.TextRange.Text, "XXXXX", "Company Name")
                        End If
                       Next objShape
                Next objSlide

           'AppPPT.Quit
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
Set AppPPT = Nothing
Set objSFolders = Nothing
No. I get Object Required for

For Each objShape In pptSlide.Shapes
 

bastanu

AWF VIP
Local time
Today, 14:59
Joined
Apr 13, 2010
Messages
1,401
HI Isaac,
It should, I think you have a few small errors:
Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide as object, objShape as object, objPresentation as object
 
Set fdg = Application.FileDialog(msoFileDialogFilePicker)
 
Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")
 
With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each objShape In objSlide.Shapes  'pptSlide.Shapes
                        If objShape.Type = TextFrame Then
                               objShape.TextRange.Text = Replace(objShape.TextRange.Text, "XXXXX",Me.CompanyName) '' "Company Name")
                        End If
                       Next objShape
                Next objSlide

           
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
           AppPPT.Quit
Set AppPPT = Nothing
Set objSFolders = Nothing
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
Still tinkering.

Code:
Private Sub Outbrief_Click()
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide As Object, objShape As Object, objPresentation As Object
 
Set fdg = Application.FileDialog(msoFileDialogFilePicker)
 
Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")
 
With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
          strSelectedItem = .SelectedItems(1)
          Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           Set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each Shape In objPresentation.Shapes
                        If Shape.Type = TextFrame Then
                               TextFrame.TextRange.Text = Replace(TextFrame.TextRange.Text, "XXXXX", "Company Name")
                        End If
                       Next Shape
                Next objSlide

           'AppPPT.Quit
    
    Else
    End If
End With
Set fdg = Nothing
Set AppPPT = Nothing
Set objSFolders = Nothing
End Sub

Object doesn't support this property or method

For Each Shape In objPresentation.Shapes
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
HI Isaac,
It should, I think you have a few small errors:
Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide as object, objShape as object, objPresentation as object

Set fdg = Application.FileDialog(msoFileDialogFilePicker)

Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")

With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each objShape In objSlide.Shapes  'pptSlide.Shapes
                        If objShape.Type = TextFrame Then
                               objShape.TextRange.Text = Replace(objShape.TextRange.Text, "XXXXX",Me.CompanyName) '' "Company Name")
                        End If
                       Next objShape
                Next objSlide

          
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
           AppPPT.Quit
Set AppPPT = Nothing
Set objSFolders = Nothing

This didn't generate errors, but it didn't replace the text.
 

bastanu

AWF VIP
Local time
Today, 14:59
Joined
Apr 13, 2010
Messages
1,401
Maybe try to step in through the code and see what is doing? Your previous post was wrong as Shape was not declared, objShape was...

Cheers,
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
Maybe try to step in through the code and see what is doing? Your previous post was wrong as Shape was not declared, objShape was...

Cheers,

Got it!!!


Code:
Const msoFileDialogFilePicker As Long = 3
Dim strSelectedFile As String
Dim AppPPT As Object, objSlide As Object, objShape As Object, objPresentation As Object

Set fdg = Application.FileDialog(msoFileDialogFilePicker)

Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
Path = objSFolders("MyDocuments")

With fdg
  .AllowMultiSelect = False
  .Filters.Add "File Type", "*.pptx", 1
  .InitialFileName = Path
   If .Show = -1 Then
    For Each strSelectedItem In .SelectedItems
           Set AppPPT = CreateObject("PowerPoint.Application")
           AppPPT.Visible = True
           Set objPresentation = AppPPT.Presentations.Open(strSelectedItem)
               For Each objSlide In objPresentation.Slides
                       For Each objShape In objSlide.Shapes  'pptSlide.Shapes
                        If objShape.Type = 1 Then
                              objShape.TextFrame.TextRange = Replace(objShape.TextFrame.TextRange, "XXXXX", "CompanyName")
                       End If
                       Next objShape
                Next objSlide

          
    Next strSelectedItem
    Else
    End If
End With
Set fdg = Nothing
          ' AppPPT.Quit
Set AppPPT = Nothing
Set objSFolders = Nothing
 

Isaac

Lifelong Learner
Local time
Today, 14:59
Joined
Mar 14, 2017
Messages
8,738
No. I get Object Required for

For Each objShape In pptSlide.Shapes
Sorry, please change this line:

For Each objShape In pptSlide.Shapes

to:

For Each objShape In objSlide.Shapes
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
So, next task is a bit more complicated. In the middle of the slide deck, I have on slide 5 of the template a slide where I list failed requirements. It has 3 text fields on it, but I need to only replace what is in the second with my failed requirements report information. The stickler is that I only need 2 failed requirements per page and I need to duplicate and insert slides in the template as necessary. I'm going to start coding this morning and post my progress and maybe ask for a bit of help. I appreciate you guys
 

Minty

AWF VIP
Local time
Today, 21:59
Joined
Jul 26, 2013
Messages
10,355
Good luck, I do a lot of PPT slide automation work, and trust me it is unbelievably frustrating.

Some of the methods have been depreciated, but are still needed as they haven't actually replaced them, and they overwrite some bits of the newer properties efforts.

Try setting a line transparency in a chart. And then try altering the line colours.
 

Isaac

Lifelong Learner
Local time
Today, 14:59
Joined
Mar 14, 2017
Messages
8,738
So, next task is a bit more complicated. In the middle of the slide deck, I have on slide 5 of the template a slide where I list failed requirements. It has 3 text fields on it, but I need to only replace what is in the second with my failed requirements report information. The stickler is that I only need 2 failed requirements per page and I need to duplicate and insert slides in the template as necessary. I'm going to start coding this morning and post my progress and maybe ask for a bit of help. I appreciate you guys
Nice sig
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
So far so good. I have the presentation making duplicates temporarily based on an input box, and each slide is individually edited based on the slide number. Now, here comes the hard part... I have an existing query that gives me all of the failed requirements in table format. I have no idea how to take the pertinent data so I can get it into the text box.
 

Isaac

Lifelong Learner
Local time
Today, 14:59
Joined
Mar 14, 2017
Messages
8,738
You could open a recordset and create whatever your "lines in the textbox" requirement is crafted from the recordset results
 

The Rev

Registered User.
Local time
Today, 17:59
Joined
Jan 15, 2003
Messages
118
Out of curiosity, is there a character limit for the SQL statement? Mine's 758 characters long because I need lots of different data for the query, but only 5 data fields from the query will get combined into the text I need to paste into the text box.
 

Users who are viewing this thread

Top Bottom