Powerpoint VBA Update Shape from database

0
votes

I have a ppt that is being saved as a pdf for use as catalog. I would like to be able to name the text shapes based on a unique product id and then update them based on a connection to an access database. I can name the shapes and update the values with vba using an input box (for testing) but I cannot figure out how to loop through all the shapes and update the shape text based on matching the unique ID criteria. Below is what I am using to test renaming and updating from an input box.

Sub UpdateShape() Dim oShape As Shape

Dim objName
On Error GoTo CheckErrors
If ActiveWindow.Selection.ShapeRange.Count = 0 Then
    MsgBox "You need to select a shape first"
    Exit Sub
End If
objName = ActiveWindow.Selection.ShapeRange(1).Name

objName = InputBox$("Assign a new name and value to this shape", "Update Shape", objName)
    If objName <> "" Then
    ActiveWindow.Selection.ShapeRange(1).Name = objName
    ActiveWindow.Selection.ShapeRange(1).TextFrame.TextRange.Text = objName
End If

Exit Sub

CheckErrors: MsgBox Err.Description

End Sub

What I have in mind is for the catalog creator to name the shapes based on the images they are putting in the catalog. The pricing will come from the database based on which customer the catalog is being created for. I would like for the vba to loop through the database records and return the sale price based on matching the product ID with the shape name.

I have tried using Set oShape = ActivePresentation.Slides("MySlide").Shapes("MyShape") and oShape.TextFrame.TextRange.Text = "objName"

But I cannot get the text to update and I cannot figure out how to use a variable in place of "MySlide"

The name of the table is tblProduct. The name of the product id field is productid. the name of the sale price field is saleprice.

I appreciate any help I can get.

Thanks

2
ms-accessvbapowerpoint

2 Answers

0
votes

To locate and modify a named shape that might appear anywhere in the presentation, you'll need to loop through all the shapes on all the slides in order to locate the one you need. It triggers a lot of passes through the presentation but shouldn't take all that long to complete. A few seconds even on large presentations/lots of replacements.

Sub Test()
    ' Call UpdateText for each replacement
    UpdateText "This", "This is the text for shape named THIS"
    UpdateText "That", "This is the text for shape named THAT"
    UpdateText "The Other", "This is the text for shape named THE OTHER"
End Sub
Function UpdateText(sShapeName As String, sNewText As String)
    Dim oSl As Slide
    Dim oSh As Shape

    For Each oSl In ActivePresentation.Slides
        For Each oSh In oSl.Shapes
            If UCase(oSh.Name) = UCase(sShapeName) Then
                oSh.TextFrame.TextRange.Text = sNewText
            End If
        Next
    Next
End Function
0
votes

I'm not clear on the problem you're having here, but to begin with, there are a few problems with your shape naming code above. See comments and try the semi-aircode below.

Sub UpdateShape()

Dim oShape As Shape

' not strictly necessary, but generally best practice
' to dim variables as the correct type
Dim objName As String

On Error GoTo CheckErrors

' This won't work .... it throws error if no selection
'If ActiveWindow.Selection.ShapeRange.Count = 0 Then

If ActiveWindow.Selection.Type = ppSelectionShapes Then
    If ActiveWindow.Selection.ShapeRange.Count = 1 Then

        objName = ActiveWindow.Selection.ShapeRange(1).Name
        objName = InputBox$("Assign a new name and value to this shape", "Update Shape", objName)
            If objName <> "" Then
                ActiveWindow.Selection.ShapeRange(1).Name = objName
                ActiveWindow.Selection.ShapeRange(1).TextFrame.TextRange.Text = objName
            End If
            Exit Sub
    End If
End If

MsgBox "You must choose one and only one shape first"
Exit Sub

CheckErrors: MsgBox Err.Description

End Sub