S Douglas - Professional Profile

ZeePain! wrote:

This seems like one of those programs that started small, grew incrementally, building internal pressure, and finally barfed all over its source code sneakers. Or something.

Option Explicit

'***************************************************************************'
'*** Quick Back Up by Stephan 
'*** 
'*** No warranties express or implied use at your own risk
'***************************************************************************'

'********************************************************************************'
'*** if bZip is set to true then Quick Zip will try and use built in windows  ***'
'*** Zipping functionality (Windows XP and Newer Only), other wise Quick zip  ***'
'*** will try and find WinZip to add the folders to a zip archive. If neither ***'
'*** of these are available then Quick zip will copy the folders directly     ***'
'*** appending a numeric integer to end of the folder                        ***'
'*** The last folder name of the destination directory will be used as the zip ***'
'*** File name or folder name if zipping is not used                          ***'
'*** Exp, the directory to back up "C:\Test" backed up to "C:\Temp\Test will  ***'
'*** become "C:\Temp\Test1.zip                                                ***'
'********************************************************************************'


'*** The directory to back up *** 'SFD
const strDirToBack = "C:\eia"

'**** The new location ***'
const strDirNewloc = "C:\TEMP\eia"

'*** Zip the files Using Windows Zip ***'
const bZip = true

'***************************************************************************'
'*** App Variables, Do No modifiy ***'
Dim objFSO
'*** End App Vars ***'
'***************************************************************************'

Call main

'***************************************************************************'
'*** Start the work *** SFD 12/17/2005
'***************************************************************************'
sub main()
dim strNum
dim strLoc
dim objShell

	Set objFSO = CreateObject("Scripting.FileSystemObject")
	strNum = GetFileNumber()

	strLoc = GetWinZipLoc()
	
	if(bZip) then
		if(CreateZip(strDirNewLoc  & strNum & ".zip ")) Then
			AddFilesZip strDirNewLoc  & strNum & ".zip ", strDirToBack
		end if
	elseif(Len(strLoc) > 0) then
	'*** Winzip is installed ***'
		set objShell = CreateObject("Shell.Application")
		strLoc = strLoc & " -a " & strDirNewLoc  & strNum & ".zip " & strDirToBack
		objshell.Open strLoc
		set objShell = Nothing
	else
	'*** WinZip is not installed Just copy the folder ***'
		objFSO.CopyFolder strDirToBack, strDirNewloc & strNum
	end if
	
	set objFSO = nothing

end sub

'***************************************************************************'
'*** Get File Number *** SFD 12/17/2005
'***************************************************************************'
function GetFileNumber()
dim objTextFile
dim strValue

	if(GetExists("foldernumber.dat") = false) then
		Set objTextFile = objFSO.CreateTextFile("foldernumber.dat")
		objTextFile.WriteLine("0")
		objTextFile.Close()
		Set objTextFile = NOthing
	end if

	Set objTextFile = objFSO.OpenTextFile("foldernumber.dat")
	
	strValue = objTextFile.ReadLine()

	objTextFile.Close
	
	set objTextFile = nothing

	if(len(strValue) < 1) or (IsNumeric(strValue) = False) then
		'**** Error ***'
		strValue = 0
	end if
	
	strValue = strValue + 1
	call SetFileNumber(strValue)
	
	GetFileNumber = strValue
end function

'***************************************************************************'
'*** Get File Number *** SFD 12/17/2005
'***************************************************************************'
sub SetFileNumber(strNewNumber)
dim objTextFile
	Set objTextFile = objFSO.OpenTextFile("foldernumber.dat", 2, False )
	
	objTextFile.WriteLine(strNewNumber)
	objTextFile.Close()

	set objTextFile = nothing
	
end sub

'***************************************************************************'
'*** Does the file exists *** SFD 12/17/2005
'***************************************************************************'
function GetExists(str)
		
	GetExists = objFSO.fileexists(str)
end function

'***************************************************************************'
'*** Get Location of Winzip from Registry *** SFD 12/17/2005
'***************************************************************************'
function GetWinZipLoc()
On Error Resume Next
dim strWinZip
dim objRegEdit
	strWinZip = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\winzip32.exe"
	
	Set objRegEdit = CreateObject("WScript.Shell")
	strWinZip = vbNullString
	strWinZip = objRegEdit.RegRead(strWinZip)
	
	Set ObjRegEdit = Nothing
	
	GetWinZipLoc = strWinZip

end function

'***************************************************************************'
'*** Create The Zip File *** SFD 12/17/2005
'***************************************************************************'
function CreateZip(strLoc)
On Error Resume Next
dim strHex
dim i
dim objTextFile

CreateZip = true

	'Create the basis of a zip file. 
	Set objTextFile = objFSO.CreateTextFile(strLoc, True) 

	strHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) 

	strLoc = vbNullstring

	For i = 0 To UBound(strHex) 
		strLoc = strLoc & Chr(strHex(i)) 
	Next 

	objTextFile.Write strLoc 
	objTextFile.Close 

	Set objTextFile = Nothing 

if err.number <> 0 then
	CreateZip = False
end if
end function


'***************************************************************************'
'*** Add Files to Zip *** SFD 12/17/2005
'***************************************************************************'
function AddFilesZip(strLoc, strback)
On Error Resume Next 

dim objApp
dim objZip

Set objApp = CreateObject("Shell.Application") 

Set objZip = objApp.NameSpace(strback) 
	If Not objZip Is Nothing Then 
		objApp.NameSpace(strLoc).CopyHere objZip.Items 
	End If 
 
wScript.Sleep(5000) 

Set objZip = Nothing 
do while(objZip is Nothing)
	wscript.sleep 3000
loop

Set objZip = Nothing 
Set objApp = Nothing

If Err.number <> 0 then 
	msgbox err.description
	err.clear
End If 

end function

ZeePain! wrote:

This seems like one of those programs that started small, grew incrementally, building internal pressure, and finally barfed all over its source code sneakers. Or something.

ZeePain! wrote:

This seems like one of those programs that started small, grew incrementally, building internal pressure, and finally barfed all over its source code sneakers. Or something.

ZeePain! wrote:

This seems like one of those programs that started small, grew incrementally, building internal pressure, and finally barfed all over its source code sneakers. Or something.

ZeePain! wrote:

This seems like one of those programs that started small, grew incrementally, building internal pressure, and finally barfed all over its source code sneakers. Or something.