domaei
23.03.2017, 21:24
Wo ist der Fehler im Code (VBA PowerPoint)?

Hallo meine lieben,

ich benötige wieder einmal eure Hilfe. Ich habe im Internet einen VBA Code gefunden der es ermöglich in einer PowerPoint Präsentation die aktuelle Uhrzeit mit Sekunden anzuzeigen. Da der Code leider nicht 64bit tauglich war hab ich ein wenig rumgetüftelt und siehe da, die Uhr selbst funktioniert schon mal. Aber leider bekomme ich ständig eine Fehlermeldung sobald die Folie gewechselt wird. "slides (unknown member): bad argument type. Excectet Collection index (string or integer). Ich verwende Windows 10 und Office 2016.

Würde mich rießig freuen wenn mir hier jemand weiterhelfen kann.

Vielen Dank im Voraus.

Leider ist der Code zu lange daher in 2 Teile.

Erster Teil:

Option Explicit

'API Declarations
Declare PtrSafe Function SetTimer Lib "user32" _
                            (ByVal hwnd As LongPtr, _
                             ByVal nIDEvent As LongPtr, _
                             ByVal uElapse As LongPtr, _
                             ByVal lpTimerFunc As LongPtr) As LongLong

Declare PtrSafe Function KillTimer Lib "user32" _
                            (ByVal hwnd As LongPtr, _
                             ByVal nIDEvent As LongPtr) As LongLong

' Public Variables
Public ClockTimerID As LongLong
Public prevSlideIdx As LongLong

Const TIMEFORMATSTRING As String = "dd.mm.yyyy - HH:mm:ss - KW :ww" 'show seconds with: "HH:mm:ss""

Dim pptEventObject As New Klasse1 'AppClassModule
'DIESE METHODE EINMALIG UNTER MAKROS STARTEN, DAMIT DAS EVENTHANDLING FUNKTIONIERT!
Sub InitializeApp()
    Set pptEventObject.App = Application
End Sub


Sub StartClockTimer()
    On Error GoTo ErrorOccurred
    
    'first make sure its not already running
    ClockTimerID = KillTimer(0, ClockTimerID)
    ClockTimerID = SetTimer(0, 0, 1000, AddressOf TimerProcClock)
    If ClockTimerID = 0 Then
        MsgBox "Unable to create the clock timer", vbCritical + vbOKOnly, "Error"
        Exit Sub
    End If

    Exit Sub
ErrorOccurred:
    MsgBox Err.Description
End Sub


Sub StopClockTimer()
    On Error GoTo ErrorOccurred
    
    If Not ClockTimerID = 0 Then
        ClockTimerID = KillTimer(0, ClockTimerID)
    End If

    Exit Sub
ErrorOccurred:
    MsgBox Err.Description
End Sub


' The defined routine gets called every nnnn milliseconds.
Sub TimerProcClock(ByVal hwnd As LongPtr, _
                    ByVal uMsg As LongPtr, _
                    ByVal idEvent As LongPtr, _
                    ByVal dwTime As LongPtr)
On Error GoTo ErrHandler
    
    If Not ActiveSlide Is Nothing Then
        ActiveSlide.Shapes("PointaixClockLabel").TextFrame.TextRange.Text = WeekdayName(Weekday((Now()))) + " " + Format(Now(), TIMEFORMATSTRING)
    End If

    Exit Sub
ErrHandler:
End Sub
 ...zum Beitrag
Antwort
von domaei
23.03.2017, 21:27

zweiter Teil:

 

Sub CreateClockShape()
    On Error GoTo AbortClockShape
    
    'first check if shape already exists
    Dim sh As Shape
    On Error Resume Next
    Set sh = ActiveSlide.Shapes("PointaixClockLabel")
    
    On Error GoTo AbortClockShape
    
    If sh Is Nothing Then
        'shape with that name does not exist, so lets create it
        With ActiveSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=300, Top:=8, Width:=75, Height:=14)
            'Set name
            .Name = "PointaixClockLabel"
            ' fill parameters
            .Fill.Visible = msoTrue
            .Fill.Solid
            .Fill.ForeColor.RGB = RGB(0, 0, 0)
            .Fill.Transparency = 0#
            ' line parameters
            .Line.Weight = 2#
            .Line.Visible = msoTrue
            .Line.ForeColor.RGB = RGB(255, 0, 0)
            .Line.BackColor.RGB = RGB(255, 255, 255)
            'Text & font size
            With .TextFrame.TextRange
                .Text = Format(Now(), TIMEFORMATSTRING)
                .Font.Size = 12
                .Font.Italic = False
                .Font.Color.RGB = RGB(255, 255, 255)
            End With
        End With
        
        Set sh = ActiveSlide.Shapes("PointaixClockLabel")
    Else
        'we found the shape - lets simply update the text
        sh.TextFrame.TextRange.Text = Format(Now(), TIMEFORMATSTRING)
    End If
  
    Exit Sub
AbortClockShape:
    MsgBox Err.Description
End Sub
Sub DeletePrevClockShape()
    On Error GoTo ErrorOccurred
    
    'If Not prevSlideIdx Is Nothing Then
    If prevSlideIdx > 0 Then
        ActivePresentation.Slides(prevSlideIdx).Shapes("PointaixClockLabel").Delete
    End If
    
    Exit Sub
ErrorOccurred:
    MsgBox Err.Description
End Sub
'returns a reference of the active slide
Function ActiveSlide() As Slide
  On Error GoTo ErrHandler
  
  Set ActiveSlide = ActivePresentation.SlideShowWindow.View.Slide
  
  Exit Function
ErrHandler:
  Set ActiveSlide = Nothing
End Function
 ...zur Antwort