Macro for Autosaving excel file once a day to a different directory with name + date

[eimisQ]

Hi, I'm looking for a macro code which autosaves excel file once a day while it's open. I have found a code which would suit me but doesn't always work, maybe somebody could help me ?

Code:

Option Explicit

Private Sub Workbook_Open()
    AutoSave 'Start Autosaving
 
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim dtTime As Date
    'Cancel next save-call.
    dtTime = GetSetting("MyAppName", "AutoSave", "SaveNext")
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave", Schedule:=False
End Sub


Private Sub AutoSave()
    Const lngFileNotFound_c As Long = 0&
    Dim strFileName As String
    Dim dtTime As Date
    'Create file name.
    strFileName = "\\INTELLINET\vieta\K-serveris\Katilinës dokumentai\NEW DB Test\1" & Format$(Now, _
        "yyyy-mm-dd") & "_" & ActiveWorkbook.Name
    If Right$(LCase$(strFileName), 4) <> ".xlsm" Then
        'Unsaved files won't have an ext yet.
        strFileName = strFileName & ".xlsm"
    End If
    'If it's already been saved today, then don't oversave:
    If LenB(Dir(strFileName)) = lngFileNotFound_c Then
        'Above lines remarked out to allow overwriting.
        ThisWorkbook.SaveCopyAs strFileName
    End If
    'Set Time interval to 5 minutes:
    dtTime = DateAdd("n", 1, Now) 'Get next save-time
    'This will be used later to cancel:
    SaveSetting "MyAppName", "AutoSave", "SaveNext", dtTime
    'Schedule next save:
    Excel.Application.OnTime dtTime, "ThisWorkbook.AutoSave"
End Sub