RPClock.xlsm

This is an Excel VBA script which has events entered and depending on the day and time and run a python program to play a MP3 or speak the text in the Excel sheet. If you'd like, just ask me to send you the code for everything. For now, I have the snippet of the code.


RPClock Excel Modules

Ce sont des modules en VBA pour vérifier l'heure et la date et faire une alarme.

'Moddule 1

'Create Row
Sub Button1_Click()
'Disable Screen Update
Application.ScreenUpdating = False

'Variable Declaration
Dim Rng As Range
Dim shtRng As Range
Dim WrkSht As Worksheet
Dim i As Integer
Dim from As String
Dim tohere As String
Dim val As Integer

'Variable Initialization
i = 1

Set WrkSht = Application.ActiveSheet
Set Rng = Selection
val = Rng.Row
from = "G" + Mid(str(val), 2)
tohere = "M" + Mid(str(val), 2)
Set shtRng = Range(from, tohere)

For Each Rng In shtRng
    With WrkSht.CheckBoxes.Add(Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Width, Height:=Rng.Height).Select
        With Selection
            .Characters.Text = Rng.Value
            .Caption = ""
            .Caption = "Day " & i
            i = i + 1
        End With
    End With
Next

i = 1

Set shtRng = Range("E" + Mid(str(val), 2))

For Each Rng In shtRng
    With WrkSht.CheckBoxes.Add(Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Width, Height:=Rng.Height).Select
        With Selection
            .Characters.Text = Rng.Value
            .Caption = ""
            .Caption = "Alarm " & i
            i = i + 1
        End With
    End With
Next

shtRng.ClearContents
shtRng.Select

'Enable Screen Update
Application.ScreenUpdating = True
End Sub

'Delete Row
Sub Button2_Click()

Dim from As String
Dim tohere As String
Dim val As Integer
Dim ws As Worksheet
Dim myRange As Range
Dim check As CheckBox
    
Set ws = Sheets("Sheet1")
    
Set Rng = Selection
val = Rng.Row
from = "E" + Mid(str(val), 2)
tohere = "M" + Mid(str(val), 2)
    
'OD Checkboxes
Set myRange = ws.Range(from, tohere)
    
For Each check In ws.CheckBoxes
     If Not Intersect(check.TopLeftCell, myRange) Is Nothing Then
         check.Delete
     End If
Next

Range("A" + Mid(str(val), 2)).Clear
Range("A" + Mid(str(val), 2)).EntireRow.Delete
End Sub

'Module 2

Dim CountDown As Date
Sub Timer()
CountDown = Now + TimeValue("00:00:01")
Application.OnTime CountDown, "Reset"
End Sub


Sub Reset()
    'On Error GoTo 10
    Dim count       As Range
    Dim shtRng      As Range
    Dim Day         As String
    Dim txt         As String
    Dim prog        As String
    Dim addRng      As String
    Dim WrkBook     As Workbook
    Dim WrkSheet    As Worksheet
    
    WrBook = "RPClock.xlsm"
    
    Set shtRng = Range("A5:A100")
    
    For Each Rng In shtRng
        
        Workbooks("RPClock.xlsm").Sheets("Sheet1").Range("A3").Value = Time()
        
10:           If Rng.Value <> "" Then
        Day = Format(Now(), "dddd")
        If Range("A" + Mid(str(Rng.Row), 2)) = Range("A3").Value Then
            If CheckDay(Rng.Row, Day) Then
                Beep
                txt = Range("D" + Mid(str(Rng.Row), 2)).Value
                For Each cb In ActiveSheet.CheckBoxes
                    If cb.Value = 1 Then
                        addRng = ActiveSheet.Shapes(cb.Name).TopLeftCell.Address
                        If addRng = Range("E" + Mid(str(Rng.Row), 2)).Address Then
                            prog = "python3 C:Users
chrdDocumentsPythonPlaysounds.py ""Chimes2"" """ & txt & """"
                            Exit For
                        Else
                            prog = "python3 C:Users
chrdDocumentsPythonText2speech.py ""--lang=en"" """ & txt & """"
                        End If
                    End If
                Next
                Call Shell(prog, vbNormalFocus)
            End If
        End If
    End If
Next

Call Timer
End Sub

Sub DisableTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=CountDown, Procedure:="Reset", Schedule:=False
End Sub

Function CheckDay(Rng As Integer, Day As String) As Boolean
    
    Dim shtRng      As Range
    Dim addRng      As String
    
    Set shtRng = Range("G" + Mid(str(Rng), 2), "M" + Mid(str(Rng), 2))

    On Error Resume Next
    
    For Each cb In ActiveSheet.CheckBoxes
        If cb.Value = 1 Then
            addRng = ActiveSheet.Shapes(cb.Name).TopLeftCell.Address
            
            Select Case addRng
                
                Case Range("G" + Mid(str(Rng), 2)).Address
                    If Day = "Sunday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("H" + Mid(str(Rng), 2)).Address
                    If Day = "Monday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("I" + Mid(str(Rng), 2)).Address
                    If Day = "Tuesday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("J" + Mid(str(Rng), 2)).Address
                    If Day = "Wednesday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("K" + Mid(str(Rng), 2)).Address
                    If Day = "Thursday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("L" + Mid(str(Rng), 2)).Address
                    If Day = "Friday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
                Case Range("M" + Mid(str(Rng), 2)).Address
                    If Day = "Saturday" Then
                        CheckDay = True
                        Exit For
                    Else
                        CheckDay = False
                    End If
                    
            End Select
        End If
    Next
    
End Function
This is a simple exel.vba alarm clock. Found on GitHub

RPClock on GitHub.com