自动创建新的 PP/Excel 工作表并更新链接

Question

我编写的 VBA 代码遇到了问题，该代码旨在执行以下操作：

定义文件路径： 该宏首先为文件路径定义几个字符串变量：originalPptPath、newPptPath、originalExcelPath、newExcelPath。 这些变量被分配了 PowerPoint 和 Excel 文件的原始版本和新 (V2) 版本的路径。

更新 PowerPoint 链接： 该宏循环遍历当前 PowerPoint 演示文稿中的每张幻灯片和形状。 对于链接对象的形状（如图表或 OLE 对象），它会检查其链接源是否包含原始 Excel 文件的路径 (originalExcelPath)。 如果是，它会将此路径替换为新的 Excel 文件路径 (newExcelPath) 并更新链接。 此步骤对于确保 PowerPoint 演示文稿中的所有数据链接都指向新版本的 Excel 文件而不是原始版本至关重要。

保存新的 PowerPoint 版本： 更新链接后，宏将当前 PowerPoint 演示文稿另存为新文件，从而有效地创建演示文稿的“版本 2”。 这是使用 SaveAs 方法和 newPptPath 完成的。

处理Excel文件： 然后，该宏使用 CreateObject("Excel.Application") 自动打开 Excel 文件。 它使用 SaveAs 方法和 newExcelPath 将此 Excel 文件另存为新文件（“V2”版本）。 最后，它关闭 Excel 应用程序。 代码是：

    Sub SaveAsNewVersionAndUpdateLinks()
        ' Define the original and new file paths
        Dim originalPptPath As String, newPptPath As String
        Dim originalExcelPath As String, newExcelPath As String
    
        ' Updated file paths
        originalPptPath = "N:\_Initiative\Clients\2023\IAG\_Comms Design\Charlie Dox\INI-VENTORS\Audience Book Test V1.pptm"
        newPptPath = "N:\_Initiative\Clients\2023\IAG\_Comms Design\Charlie Dox\INI-VENTORS\Audience Book Test V2.pptm"
        originalExcelPath = "\\sydfpr05a\IPG\AUS-MBW\_Initiative\Clients\2023\IAG\_Comms Design\Charlie Dox\INI-VENTORS\Ini Ventors Draft Excel V1.xlsm"
        newExcelPath = "\\sydfpr05a\IPG\AUS-MBW\_Initiative\Clients\2023\IAG\_Comms Design\Charlie Dox\INI-VENTORS\Ini Ventors Draft Excel V2.xlsm"
    
        ' Update links in the current presentation to point to the new Excel file
        Dim slide As Object, shape As Object
        For Each slide In ActivePresentation.Slides
            For Each shape In slide.Shapes
                If shape.Type = msoLinkedOLEObject Or shape.Type = msoLinkedChart Then
                    If InStr(shape.LinkFormat.SourceFullName, originalExcelPath) > 0 Then
                        shape.LinkFormat.SourceFullName = Replace(shape.LinkFormat.SourceFullName, originalExcelPath, newExcelPath)
                        shape.LinkFormat.Update
                    End If
                End If
            Next shape
        Next slide
    
        ' Save the current PowerPoint as a new file with updated links
        ActivePresentation.SaveAs newPptPath, ppSaveAsOpenXMLPresentationMacroEnabled
    
        ' Close the original presentation
        ActivePresentation.Close
    
        ' Create and open Excel application, save the workbook as a new file, then close Excel
        Dim excelApp As Object
        Set excelApp = CreateObject("Excel.Application")
        excelApp.Workbooks.Open originalExcelPath
        excelApp.ActiveWorkbook.SaveAs newExcelPath
        excelApp.Quit
    
        ' Optionally, open the new PowerPoint file (V2)
        ' Application.Presentations.Open newPptPath
    End Sub

问题：当我打开 V2 PP 文件时，图表仍然链接回 V1 excel。我什至通过“编辑文件链接”手动检查，它告诉我它仍然链接到 V1 文件（下图）：

**我的代码有问题吗，我该如何解决这个问题。

新的 PP V2 图表将链接到新的 V2 Excel 工作表。 **

Answer 1

替换功能区分大小写。

请尝试一下。

Shape.LinkFormat.SourceFullName = Replace(vcase(Shape.LinkFormat.SourceFullName), UCase(originalExcelPath), newExcelPath)