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中的某个范围。 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过程专注于幻灯片的日志记录更改。

VBA PowerPoint在幻灯片中的幻灯片更改中写入Excel

2 个答案: