ensure backup function occurs once a month

[Rhonda]

I have this backup function and I want to include code to
ensure that the backup only occurs once for the end of
the month. If someone tries to do it again they get a
message saying that it has already been backed up today?

Dim awb As Workbook, BackupFileName As String, i As
Integer, OK As Boolean
If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
Set awb = ActiveWorkbook
If awb.Path = "" Then
Application.Dialogs(xlDialogSaveAs).Show
Else
BackupFileName = awb.FullName
i = 0
While InStr(i + 1, BackupFileName, ".") > 0
i = InStr(i + 1, BackupFileName, ".")
Wend
If i > 0 Then BackupFileName = Left
(BackupFileName, i - 1)
'BackupFileName = BackupFileName & ".bak"
OK = False
On Error GoTo NotAbleToSave
With awb
Application.StatusBar = "Saving this
workbook..."
.Save
Application.StatusBar = "Saving this workbook
backup..."

ThisWorkbook.SaveCopyAs Left
(ThisWorkbook.FullName, Len( _
ThisWorkbook.FullName) - 4) & Format
(Date, "_yyyy_mm_dd") & ".bak"



'.SaveCopyAs BackupFileName
OK = True
End With
End If
NotAbleToSave:
Set awb = Nothing
Application.StatusBar = False
If Not OK Then
MsgBox "Backup Copy Not Saved!", vbExclamation,
ThisWorkbook.Name

Else
MsgBox "Backup was successful!", vbInformation,
ThisWorkbook.Name

End If

 

[Rhonda]

I did this:

If Dir(ThisWorkbook.Path & ThisWorkbook.FullName
& "_yyyy_mm.bak")

but it ignores it.

Private Sub Backup_Button_Click()
Dim awb As Workbook, BackupFileName As String, i As
Integer, OK As Boolean
If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
Set awb = ActiveWorkbook
If awb.Path = "" Then
Application.Dialogs(xlDialogSaveAs).Show
Else
BackupFileName = awb.FullName
i = 0
While InStr(i + 1, BackupFileName, ".") > 0
i = InStr(i + 1, BackupFileName, ".")
Wend
If i > 0 Then BackupFileName = Left
(BackupFileName, i - 1)
'BackupFileName = BackupFileName & ".bak"
OK = False
On Error GoTo NotAbleToSave


If Dir(ThisWorkbook.Path & ThisWorkbook.FullName
& "_yyyy_mm.bak") <> "" Then

MsgBox "File Already Exists!", vbExclamation,
ThisWorkbook.Name


Else

With awb
Application.StatusBar = "Saving this
workbook..."
.Save
Application.StatusBar = "Saving this workbook
backup..."



ThisWorkbook.SaveCopyAs Left
(ThisWorkbook.FullName, Len( _
ThisWorkbook.FullName) - 4) & Format
(Date, "_yyyy_mm") & ".bak"



'.SaveCopyAs BackupFileName
OK = True

End With
End If
End If
NotAbleToSave:
Set awb = Nothing
Application.StatusBar = False
If Not OK Then
MsgBox "Backup Copy Not Saved!", vbExclamation,
ThisWorkbook.Name

Else
MsgBox "Backup was successful!", vbInformation,
ThisWorkbook.Name

End If
End Sub

 

[Tom Ogilvy]

You don't need both Path and Fullname, Fullname includes the path
You need to build a date string, not just append the literal string
"_yyyy_mm".
You also need to remove the existing extension and put it on the end.

If Dir( Left(ThisWorkbook.FullName,len(thisWorkbook.Fullname)-4) &
format(Date,"_yyyy_mm") & ".bak") <> "" then
' file exists
Else
' file doesn't exist
End if

as an illustration from the immediate window:

? thisworkbook.FullName
C:\Data\aaa_scroll_area.xls

? Left(ThisWorkbook.FullName,len(thisWorkbook.Fullname)-4) &
format(Date,"_yyyy_mm") & ".bak"
C:\Data\aaa_scroll_area_2003_09.bak

 

[Rhonda]

Thanks again Tom. Before I got your message I ran what I
had through the debugger and when the cursor was above
the path I realized they both had the same info. I had
recoded it except for the format date part. There's alot
to know about this language!!