PDA

View Full Version : Solved: Create txt Backup



Stromma
06-07-2004, 09:29 AM
Hi All!

I'm trying to help my wife to create a simple Workbook Backup. This backup must save all data to the Floppy Drive. Her Workbook contains 4 different sheets: Data, Article, Contacts & Information. Sheets Data is between 2.5 to 3 Mb and because of this i save all sheets separetly as txt. In txt format sheets Data changes between 1 to 1.2 Mb (Floppy Disc 1), the other 3 can be saved to the same disc (Floppy Disc 2).

This is what i'm trying to do... :

Create a hardrive temp folder C:\New Backup.

Copy each sheet separetly to a new book and save in C:\New Backup as txt.

Ask for disc 1.

Copy sheets Data.txt from C:\New Backup to Disc 1.

Ask for Disc 2.

Copy sheets Article, Contacts & Information from C:\New Backup to Disc 2.

Delete all files in C:\New Backup.

Delete folder C:\New Backup.

Everything works as i want it to, but just to be on the safe side, since i'm not very good on VBA, i thought i might ask some experts to have a look at it.

I know it's quit much code, but any comment or suggestion will be highly appreciated.

Here's what i come up with so far:
Sub Create_Backup()
Dim fsoObj As Scripting.FileSystemObject, Fs As Object
Dim strPath As String, strFileMask As String, f As String, stKallFil As String
Set fsoObj = New Scripting.FileSystemObject

Set Fs = CreateObject("Scripting.FileSystemObject")
If MsgBox(strExcelApp & "Do you want to create a Backup?", vbYesNo + vbQuestion) = vbNo Then

Exit Sub

End If

Application.DisplayAlerts = False

Application.EnableEvents = False

Application.ScreenUpdating = False


'Check Drive C And Create Temp Folder New Backup

With fsoObj

If .Drives("C:").IsReady = True Then

If .FolderExists("C:\New Backup\") Then

MsgBox "Folder C:\New Backup allready exists!", vbInformation

Else

.CreateFolder ("C:\New Backup")

MsgBox "Folder C:\New Backup was successfully created!", vbInformation
End If

End If

End With


'Copy Sheets Data And Save As Data.txt To C:\New Backup

With fsoObj

If .Drives("C:").IsReady = True Then

Sheets("Data").Select

Sheets("Data").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

MsgBox "Sheets Data was successfully copied to C:\New Backup\Data.txt!", vbInformation

End If

End With


'Copy Sheets Article And Save As Article.txt To C:\New Backup

With fsoObj

If .Drives("C:").IsReady = True Then

Sheets("Article").Select

Sheets("Article").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Article.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

MsgBox "Sheets Article was successfully copied to C:\New Backup\Article.txt!", vbInformation

End If

End With

'Copy Sheets Contacts And Save As Contacts.txt To C:\New Backup

With fsoObj

If .Drives("C:").IsReady = True Then

Sheets("Contacts").Select

Sheets("Contacts").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Contacts.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

MsgBox "Sheets Contacts was successfully copied to C:\New Backup\Contacts.txt!", vbInformation

End If

End With


'Copy Sheets Information And Save As Information.txt In C:\New Backup

With fsoObj

If .Drives("C:").IsReady = True Then

Sheets("Information").Select

Sheets("Information").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Information.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

MsgBox "Sheets Information was successfully copied to C:\New Backup\Information.txt!", vbInformation

End If

End With

Sheets("Start").Activate

Range("B2").Activate

Application.ScreenUpdating = True

'Create Backup Disc 1
MsgBox "Please insert Backup Disc One! Click OK to continue!", vbExclamation


'Check Drive A:\
Disc1:

With fsoObj

If .Drives("A:").IsReady = False Then

If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc One! Continue?", vbYesNo + vbQuestion) = vbNo Then

MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical

GoTo Finish

End If

GoTo Disc1

End If

End With


'Clear Backup Disc One
On Error Resume Next
strPath = "A:\"

strFileMask = "*.*"

With fsoObj

If Dir(strPath & strFileMask) <> "" Then

Kill strPath & strFileMask

End If
Fs.DeleteFolder "A:\*.*", True

End With

MsgBox "Backup Disc One was successfully cleared!", vbInformation


'Copy Data.txt From C:\ To A:\
stKallFil = "C:\New Backup\Data.txt"

With fsoObj

.CopyFile Source:=stKallFil, Destination:="a:\"

MsgBox "Sheets Data was successfully copied from C:\New Backup\Data.txt to A:\Data.txt!", vbInformation

End With

MsgBox "Backup Disc One was successfully created!", vbInformation


'Backup Disc 2
MsgBox "Please insert Backup Disc Two! Click OK to continue!", vbExclamation

'Check Drive A:\
Disc2:

With fsoObj

If .Drives("A:").IsReady = False Then

If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc Two! Continue?", vbYesNo + vbQuestion) = vbNo Then

MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical

GoTo Finish

End If

GoTo Disc2

End If

End With


'Clear Backup Disc Two
On Error Resume Next
strPath = "A:\"

strFileMask = "*.*"

With fsoObj

If Dir(strPath & strFileMask) <> "" Then

Kill strPath & strFileMask

End If
Fs.DeleteFolder "A:\*.*", True

End With

MsgBox "Backup Disc Two was successfully cleared!", vbInformation


'Copy Article.txt From C:\ To A:\
stKallFil = "C:\New Backup\Article.txt"

With fsoObj

.CopyFile Source:=stKallFil, Destination:="a:\"

MsgBox "Sheets Article was successfully copied from C:\New Backup\Article.txt to A:\Article.txt!", vbInformation

End With

'Copy Contacts.txt From C:\ To A:\
stKallFil = "C:\New Backup\Contacts.txt"

With fsoObj

.CopyFile Source:=stKallFil, Destination:="a:\"

MsgBox "Sheets Contacts was successfully copied from C:\New Backup\Contacts.txt to A:\Contacts.txt!", vbInformation

End With

'Copy Information.txt From C:\ To A:\
stKallFil = "C:\New Backup\Information.txt"

With fsoObj

.CopyFile Source:=stKallFil, Destination:="a:\"

MsgBox "Sheets Information was successfully copied from C:\New Backup\Information.txt to A:\Information.txt!", vbInformation

End With

MsgBox "Backup Disc Two was successfully created!", vbInformation

MsgBox "Backup completed!", vbInformation


'Delete Temporary Folder C:\New Backup And Files
Finish:

On Error Resume Next

With fsoObj

Kill "C:\New Backup\*.*"

MsgBox "All files in folder C:\New Backup was successfully deleted!", vbInformation
RmDir "C:\New Backup"

MsgBox "Folder C:\New Backup was successfully deleted!", vbInformation

End With

Set fsoObj = Nothing

Application.DisplayAlerts = True

Application.EnableEvents = True
End Sub

Please, be nice :giggle

/Roger

jamescol
06-07-2004, 10:08 AM
Roger,
Can you tell us what versions of Excel and Windows are you using? And also what, if any, errors/problems you are seeing?


Thanks,
James

Stromma
06-07-2004, 10:32 AM
Hi James

Thanks for your reply!

I'm using Office 2000 at home and i belive that my wife are running Office 2003 at work.

As i said in my first post, it all works ok on my machine (Office 2000).

I just want to make shure that nothing can go wrong when my wife is using the backup, because if it does i probably have the pleasure of having an extremely cold summer... :argue

/Roger

Richie(UK)
06-07-2004, 01:01 PM
Hi Roger,

There is a lot of repetition in your code. Try to create separate functions/subs for code that is repeated, or use loops to repeat the common parts. This will help you to create 'modular' code that is easier to write and easier to debug.

If I get time I'll put something together later to illustrate.

Stromma
06-07-2004, 04:20 PM
Hi Richie

As i said, all suggestions are more than welcome :006:

The code i posted was sort of a "step by step" code with lot's of Msgboxes etc to keep track of what was happening.

I posted it just to illustrate what i was trying to do, i'm not always shure myself :roll:

In the last version their are still some repeats. For ex:

Sheets("Data").Select

Sheets("Data").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

I tried using:

Sheets("Data").SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False

But when i tried this it renamed the workbook to the last sheet, Information.txt. Another repeat is the Clear Floppy. I haven't managed to loop through this twice, so i ended up doing it once for each Disc. :dunno

The first file i copy to Disc 1 feels ok, but with the other 3 i copy one at the time and i suppose that their is a way to copy all 3 together?

Anyway, here is the "short" version. If you feel that your having to much sparetime, maybe you would be kind enough to make some comments?


Sub Create_Backup()
Dim fsoObj As Scripting.FileSystemObject, Fs As Object
Dim strPath As String, strFileMask As String, f As String, stKallFil As String
Set fsoObj = New Scripting.FileSystemObject

Set Fs = CreateObject("Scripting.FileSystemObject")
If MsgBox(strExcelApp & "Do you want to create a Backup?", vbYesNo + vbQuestion) = vbNo Then

Exit Sub

End If

Application.DisplayAlerts = False

Application.EnableEvents = False

With fsoObj

If .FolderExists("C:\New Backup\") Then

Else

.CreateFolder ("C:\New Backup")
End If

Application.ScreenUpdating = False

Sheets("Data").Select

Sheets("Data").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Data.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

Sheets("Article").Select

Sheets("Article").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Article.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

Sheets("Contacts").Select

Sheets("Contacts").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Contacts.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

Sheets("Information").Select

Sheets("Information").Copy

ActiveWorkbook.SaveAs Filename:="C:\New Backup\Information.txt", FileFormat:=xlText, CreateBackUp:=False

ActiveWindow.Close

Sheets("Start").Activate

Range("B2").Activate

Application.ScreenUpdating = True
MsgBox "Please insert Backup Disc One! Click OK to continue!", vbExclamation
Disc1:

If .Drives("A:").IsReady = False Then

If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc One! Continue?", vbYesNo + vbQuestion) = vbNo Then

MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical

GoTo Finish

End If

GoTo Disc1

End If

On Error Resume Next
strPath = "A:\"

strFileMask = "*.*"

If Dir(strPath & strFileMask) <> "" Then

Kill strPath & strFileMask

End If
Fs.DeleteFolder "A:\*.*", True
stKallFil = "C:\New Backup\Data.txt"

.CopyFile Source:=stKallFil, Destination:="a:\"

MsgBox "Backup Disc One was successfully created!", vbInformation
MsgBox "Please insert Backup Disc Two! Click OK to continue!", vbExclamation
Disc2:

If .Drives("A:").IsReady = False Then

If MsgBox(strExcelApp & "No disc was found! Please insert Backup Disc Two! Continue?", vbYesNo + vbQuestion) = vbNo Then

MsgBox "Backup was not completed! Please create a new Backup as soon as possible!", vbCritical

GoTo Finish

End If

GoTo Disc2

End If
On Error Resume Next
strPath = "A:\"

strFileMask = "*.*"

If Dir(strPath & strFileMask) <> "" Then

Kill strPath & strFileMask

End If
Fs.DeleteFolder "A:\*.*", True
stKallFil = "C:\New Backup\Article.txt"

.CopyFile Source:=stKallFil, Destination:="a:\"
stKallFil = "C:\New Backup\Contacts.txt"

.CopyFile Source:=stKallFil, Destination:="a:\"
stKallFil = "C:\New Backup\Information.txt"

.CopyFile Source:=stKallFil, Destination:="a:\"
Application.DisplayAlerts = True

Application.EnableEvents = True

MsgBox "Backup Disc Two was successfully created!", vbInformation

MsgBox "Backup completed!", vbInformation
Finish:

On Error Resume Next

Kill "C:\New Backup\*.*"
RmDir "C:\New Backup"

End With

Set fsoObj = Nothing
End Sub


/Roger :bore

mark007
06-08-2004, 04:47 AM
For creating the local copies without using the selects you could use something like:


Sub CreateLocalDiskBackup()
Dim strFileName As String
strFileName = ThisWorkbook.FullName
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
SaveSheet ws.Name
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs strFileName, xlWorkbookNormal
Application.DisplayAlerts = True
End Sub


Sub SaveSheet(strName As String)
ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText
End Sub


Also, I think you should change the code you have so far to ask before deleting everything off the floppy. Otherwise valuable data could be lost.

:)

Stromma
06-08-2004, 12:08 PM
Hi Mark

Thanks for your reply!

This works fine except from an error in line:

ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText

With this in my code it works fine:
Dim strFileName As String, ws As Worksheet

strFileName = ThisWorkbook.FullName

For Each ws In ThisWorkbook.Worksheets

SaveSheet ws.Name

Next

ThisWorkbook.SaveAs strFileName, xlWorkbookNormal

Also, I think you should change the code you have so far to ask before deleting everything off the floppy. Otherwise valuable data could be lost.
You are absolutely right!

In my original code (in swedish, i didn't have the energy to translate all msgboxex...) a vbYes/No Msgbox occur before the "Clear Floppy". I do this to prevent any errors with disc space (backup takes about 1.3 mb in each disc) when i run the code in "the right" workbook.

/Roger

mark007
06-09-2004, 03:54 AM
This works fine except from an error in line:

ThisWorkbook.Sheets(strName).SaveAs "C:\New Backup\" & strName & ".txt", xlText


What's the error?

:)

Stromma
06-09-2004, 04:42 AM
Hi Mark


My misstake...

Nothings wrong with your code, it works fine!

Any suggestions about the rest of the code?

As i said, it worked to begin with, but i'm sure their must be more things i can do differently?
/Roger

mark007
06-09-2004, 04:55 AM
There's nothing in the rest of it that stands out as being problematic other than not asking about deleting the files. There are a few extra things that could be wrapped into subs I guess to avoid repetition but as logn as it works this isn't important really.

:)

Stromma
06-09-2004, 01:31 PM
Hi All :hi:


With that last post from Mark i think the most have been said and done?

Anyway, i posted this to see what parts i could have done differently, and i learn something new every day :type

Thanks Richie, James and Mark for taking up your time reviewing this, it's highly appreciated :yes

/Roger