Ms access Powerpoint VBA从数据库更新形状

我有一个ppt，它被保存为pdf格式，作为目录使用。我希望能够根据唯一的产品id命名文本形状，然后根据与access数据库的连接进行更新。我可以使用用于测试的输入框来命名形状并使用vba更新值，但我不知道如何循环遍历所有形状并基于匹配唯一ID标准来更新形状文本。下面是我用来测试从输入框重命名和更新的内容

子更新图形 形状暗淡

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

检查错误： MsgBox错误说明

端接头

我想到的是，目录创建者可以根据它们放在目录中的图像来命名形状。定价将来自创建目录所基于的客户数据库。我希望vba通过数据库记录进行循环，并根据产品ID与形状名称的匹配返回销售价格

我尝试过使用Set oShape=ActivePresentation.SlidesMySlide.ShapesMyShape和 oShape.TextFrame.TextRange.Text=objName

但我无法更新文本，也无法找出如何使用变量代替MySlide

该表的名称为tblProduct。product id字段的名称为productid。sale price字段的名称为saleprice

我很感激能得到的任何帮助

---

谢谢

我不清楚您在这里遇到的问题，但首先，上面的形状命名代码存在一些问题。请参阅注释并尝试下面的半自动代码

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

---

要查找和修改可能出现在演示文稿中任何位置的命名形状，您需要循环浏览所有幻灯片上的所有形状，以便找到所需的形状。它会在演示过程中引发大量的过程，但不应该花费那么长的时间来完成。即使是大型演示/大量替换，也只需几秒钟

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

---

史蒂夫，这正是我想要的！我让它和我的变量一起工作。我将打开access查询来循环记录以更新每个字段。非常感谢您抽出时间回答我的问题。我说服自己不再出售我的合并插件，是吗-