VBA PowerPoint在幻灯片放映中更改幻灯片时写入Excel

我正在尝试记录1。什么幻灯片和2。每次在演示模式下查看幻灯片时创建电子表格的时间。我不希望在执行此操作时打开电子表格，我希望它自动保存。我已经胡闹了几个小时了，我已经取得了不同程度的成功。我似乎无法使它按预期工作

以下是我到目前为止拼凑的代码：

Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim strSheet As String
    Dim strPath As String
    Dim curentSlide As Integer
    Dim timez As Date
    Dim z As Integer
    strSheet = "test.xlsx"
    strPath = "C:\PPToutput\"
    strSheet = strPath & strSheet
    Dim counter As Integer
    counter = 0
    counter = counter + 1

    currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
    timez = Now()

    If Not IsNull(appExcel) And counter < 2 Then
        Set appExcel = CreateObject("Excel.Application")
        appExcel.Application.DisplayAlerts = False
        appExcel.Workbooks.Open (strSheet)
        Set wkb = appExcel.ActiveWorkbook
        Set wks = wkb.Sheets(1)
        wks.Activate
    End If
    appExcel.Application.Visible = True
    Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
    Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
    wks.Columns.AutoFit
    wkb.SaveAs
    Set appExcel = Nothing
    appExcel.Workbooks.Close
    appExcel.Quit
    Set appExcel = Nothing
End Sub

---

我还没有试过代码，但我注意到这行代码：

appExcel.Application.Visible = False

在excel程序执行某些操作之后出现。我想工作簿的开头应该是可见的，因为它发生在这一行之前

此外，我看不出您在哪里告诉OnSlideShowPageChange子系统有关您在SlideShowBegin子系统中创建的工作簿的任何信息。您告诉它对一个范围执行某些操作，而该范围不是您之前声明的范围。所以，它认为您在powerpoint中谈论的是某个范围。powerpoints有射程吗

另一个错误是你把所有的公开声明都设置为零。一旦你再给他们打电话，你就什么也没打了。在错误处理程序中这样做仍然是一个好主意，但不是作为流程的正常部分

看看我所做的[未经测试的]更改，看看它们是否有意义：

Public appExcel As Excel.Application
Public wkb As Excel.Workbook
Public wks As Excel.Worksheet
Public rng As Excel.Range
Public strSheet As String
Public strPath As String
Public intRowCounter As Integer
Public intColumnCounter As Integer
Public itm As Object

Sub SlideShowBegin()
On Error GoTo ErrHandler

strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder

Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
Dim placeholder1 As String
Dim placeholder2 As String
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()

Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = False
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
wks.Range("A1").Value = "Current Slide"
wks.Range("B1").Value = "Time"

Exit Sub

ErrHandler:      
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, _
        "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, _
        "Error"
    End If

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing

End Sub

Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
   Dim curentSlide As Integer
   Dim timez As Date
   Dim z As Integer
   Dim placeholder1 As String
   Dim placeholder2 As String

   currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
   timez = Now()
   wks.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
   wks.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
   wks.Columns.AutoFit
   wkb.Save

   If SSW.View.CurrentShowPosition = _
        SSW.Presentation.SlideShowSettings.EndingSlide Then
        wkb.Save
        wkb.Close
    End If
End Sub
Sub SlideShowEnd()
    wkb.Save
    wkb.Close
End Sub

---

我重新安排了您的代码，使初始化只在幻灯片放映期间发生一次。我添加了另一个过程，以便在幻灯片放映结束后关闭Excel

Private appExcel As Excel.Application
Private wkb As Excel.Workbook
Private wks As Excel.Worksheet
Private counter As Integer

Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)

    ' initialization
    Dim strSheet As String
    Dim strPath As String
    strSheet = "test.xlsx"
    strPath = "C:\PPToutput\"
    strSheet = strPath & strSheet
    Debug.Print strSheet, appExcel Is Nothing
    If appExcel Is Nothing Then
        Set appExcel = CreateObject("Excel.Application")
        appExcel.Application.DisplayAlerts = False
        appExcel.WindowState = xlMinimized
        appExcel.Visible = True
        Set wkb = appExcel.Workbooks.Open(strSheet)
        Set wks = wkb.Sheets(1)
        counter = wks.UsedRange.Rows.Count - 1
    End If

    ' make log entry
    Dim currentSlide As Integer
    currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
    counter = counter + 1
    wks.Range("A" & counter).Value = "Slide " & currentSlide
    wks.Range("B" & counter).Value = Now()

End Sub

Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
    If Not appExcel Is Nothing Then
        wks.Columns.AutoFit
        appExcel.WindowState = xlNormal
        wkb.Close True
        appExcel.Quit
    End If
    Set appExcel = Nothing
End Sub

---

如果是我的代码，我也会将初始化代码分解出来，并将其放在自己的过程中，以便OnSlideShowPageChange过程将重点放在幻灯片更改的记录上。

具体说明哪些部分未按预期工作。顺便说一句，我不想打开电子表格。。。您的意思是不希望Excel可见或根本不打开？如果Excel未打开，则很难写入某个范围…让我澄清一下：我希望Excel在写入时从用户的视图中隐藏。这是为了记录幻灯片之间以及从开始到结束的PowerPoint演示时间。理想情况下，脚本将在后台打开Excel，每次幻灯片更改时写一行新行，并在PowerPoint演示文稿结束时保存并关闭。希望上面编辑的代码更容易阅读。我知道代码有缺陷。它打开了太多Excel实例而未正确写入。您使用的PowerPoint版本是什么？这段代码是否在外接程序中运行？以下是一些想法：1将Excel对象变量声明为静态，否则它们将始终被创建为新的，从而触发Excel新实例的创建；2使用appExcel不需要测试它是否初始化；3将计数器声明为静态；4如果Excel工作簿位置实际上是硬编码的，将其设置为常量。最好将幻灯片索引和时间写入数组；然后，您可以在幻灯片放映结束时打开电子表格/写入电子表格/关闭电子表格，而不是反复启动Excel或在整个幻灯片放映过程中一直打开它。这是一个非常好的主意。我只是指出了可能导致OP的代码无法正常工作的错误。不过你是对的。那将是一个更好的方式。我真的应该评论OP的帖子，而不是你的。听起来我不是在批评你。