ensure backup function occurs once a month

  • Thread starter Thread starter Rhonda
  • Start date Start date
R

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
 
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
 
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
 
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!!
 
Back
Top