Time based macro running multiple times

Hello Forum,

I'm having the following problem with a macro I've written to run at a certain time of day (Note: Due to work restrictions I cannot use windows scheduler to run the macro at the time required), the code runs several times and thus generates multiple emails. I'm wondering if there is a simple way to solve this so that it only runs once. Code is below:

Dim TimeToRun

Sub auto_open()
    Call ScheduleCopyPriceOver
End Sub

Sub ScheduleCopyPriceOver()

    TimeToRun = Now + TimeValue("00:00:01")
    Application.OnTime TimeToRun, "ScheduleCopyPriceOver"

    If Time = TimeSerial(7, 30, 0) Then
        Application.OnTime TimeToRun, "CopyPriceOver"
    End If

End Sub

Sub CopyPriceOver()
    
Dim txtfilename As String
Dim currentWb As Workbook
Dim openWb As Workbook
Dim newWb As Workbook
Dim openWs As Worksheet
Dim currentWs As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String


txtfilename = "file location"

Set currentWb = ThisWorkbook

Set openWb = Workbooks.Open(txtfilename)
    
openWb.Sheets("Tabelle1").Activate

ActiveSheet.Columns("A:F").Select

Selection.Copy

currentWb.Sheets("Tabelle1").Activate

ActiveSheet.Cells(1, 1).Activate

ActiveSheet.Paste

Calculate

currentWb.Save

openWb.Close
    
Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

With OutMail
    
    .To = "boss"
    .CC = "me"
    .BCC = ""
    .Subject = "Update"
    .attachments.Add currentWb.FullName
    .send
    
End With

Set OutMail = Nothing
Set OutApp = Nothing
    
Call ScheduleCopyPriceOver

End Sub

Sub auto_close()

    On Error Resume Next

    Application.OnTime TimeToRun, "ScheduleCopyPriceOver", , False

    ActiveWorkbook.Close

End Sub

Thanks in advance!