VBA PowerPoint寫入幻燈片的幻燈片更改

Question

我試圖記錄（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 

Answer 1

的事，但我注意到的是這一行：

appExcel.Application.Visible = False 

來後excel程序做的東西。我可以想象這個工作簿的打開是可見的，因爲這發生在這一行之前。

此外，我沒有看到你在哪裏告訴OnSlideShowPageChange子項關於在SlideShowBegin子項中創建的工作簿的任何內容。你正在告訴它做一些範圍內的事情，這不是你之前宣佈的範圍。所以，它認爲你在談論某個範圍的幻燈片。 Powerpoint甚至有範圍嗎？

另一個錯誤是您將所有公開聲明設置爲空。一旦你嘗試再次打電話給他們，你什麼都不會打電話。在錯誤處理程序中執行該操作仍然是一個好主意，但不是該過程的正常部分。

看那[未經測試]改變我做了，看看它們是否有意義：

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 

Answer 2

我重新安排你的代碼位，所以只初始化在幻燈片放映期間發生一次。一旦幻燈片放映結束，我添加了另一個過程來關閉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程序集中的幻燈片變化的記錄。