Solved

What is causing this script to not delete new folders?

Posted on 2008-10-07
3
187 Views
Last Modified: 2012-05-05
This script runs correctly except that its waits till the next day before it will delete files in the FolderBackup directory. If those files are present, and its the same day then the script just stops. Not sure why?

I'd like to be able to run it multiple times a day and have it act the same way, but I dont see why it only deletes the folders when they are more than 1 day diffrent (date must be diffrent not really 24 hours).
'Generic Variables used in this script
On Error Resume Next
Dim fso, fl, flName, fldrError, Today, tMonth, tDay, thour, subject, msg, sender, recipients, wPath 
Dim aPath, path, info, settings, admin, source, additionalRecipients, fList, bPath, flFolder1, flFolder2, flFolder3
 
'Global Settings
sender = "archive@skyline.com" 
admin = "johngoering@skyline.com"
dPath = "\\backupserv1\Archive\SAP\DIY\"
sPath = "\\backupserv1\Archive\SAP\Solutions\"
 
'Getting todays date as YYYY-MM-DD-HH-MM 
tMonth = Month(Now)
If (tMonth < 10) Then
	tMonth = "0" & tMonth
End If
 
tDay = Day(Now)
If (tDay < 10) Then
	tDay = "0" & tDay
End If
Today = Year(Now) & "-" & tMonth & "-" & tDay & "-" & Hour(now) & "-" & Minute(Now)
Set fso = CreateObject("Scripting.FileSystemObject")
'INI file with Archive location for ART, Design, PM and CAD
Set f = fso.OpenTextFile("SAPArchive.ini",1)
 
Do While f.AtEndOfStream <> True
	info = f.ReadLine
	settings = Split(info,";",-1,1)
	source = settings(0)
	path = settings(1)
	If (UBound(settings) > 1) Then
		additionalRecipients = settings(2)
	Else
		additionalRecipients = ""
	End If
	folderMove source, path, additionalRecipients
 
Loop
 
'Folder Move 
Sub folderMove(source, path, additionalRecipients)
	If Not(additionalRecipients = "") Then
		recipients = admin & "," & additionalRecipients
	Else
		recipients = admin
	End If
	Err.Clear
	Set workingFolder = fso.GetFolder(path)
	Set workingFC = workingFolder.SubFolders
	If fso.FolderExists(path & "FolderBackup") Then
	fso.DeleteFolder path & "FolderBackup", true
	End If
	
	If Not(Err.Number = 0) Then
		subject = "SAP " & source & " Backup Folder Deletion Failed"
		msg = "Folder Deletion Failed: " & Err.Number & " : " & Err.Description
		sendMail sender, recipients, subject, msg
		Err.Clear
	End If
 
	fso.CreateFolder path & "FolderBackup"
	fso.CreateFolder path & "FolderBackup\" & Today
	bPath = path & "FolderBackup\" & Today & "\"
	msg = ""
	subject = ""
 
	For each fl in workingFC
		flName = fl.name	
		If Not(flName = "Logs") AND Not(flName = "FolderBackup") Then
			nameOk = True
			For i = 1 to Len(flName)
				If Asc(Mid(flName, i, 1)) = 63 Then
					nameOk = False
				End If
			Next
			If nameOk = True Then
				fList = flName & vbNewLine
				'Log folder to be moved
				LogList fList, source, path
				'Split Folder into seperate options for determining location.
				flOptions = Split(flName,"-",-1,1)
				flType = UCase(flOptions(0))
				If (flType = "D" Or flType = "S") And IsNumeric(flOptions(1)) And Len(flOptions(1)) = 10 Then
					If flType = "D" Then
						aPath = dPath
					Else
						aPath = sPath
					End If
					flFolder1 = Left(flOptions(1), 4)
					flFolder2 = Right(Left(flOptions(1), 7), 3)
					flFolder3 = Right(flOptions(1), 3)
					
					'Check to see if the SAP Project Number grouping folder exists, create if not.  
					'Folders named  nnnn(nnnn is the first 4 numbers of the numeric protion of the Project Number)
					If Not(fso.FolderExists(aPath & flFolder1)) Then
						AddNewFolders flFolder1, aPath
					End If
					'Create Project Second Level Folder based on next 3 numbers so folder path is nnnn/nnn
					If Not(fso.FolderExists(aPath & flFolder1 & "\" & flFolder2)) Then
						wPath = aPath & flFolder1 & "\"
						AddNewFolders flFolder2, wPath
					End If
					
					'Check to see if the specific Project Number folder exists, create if not.
					'Folder is named based on the last 3 digits of Project Number
					If Not(fso.FolderExists(aPath & flFolder1 & "\" & flFolder2 & "\" & flFolder3)) Then
						wPath = aPath & flFolder1 & "\" & flFolder2 & "\"
						AddNewFolders flFolder3, wPath
					End If
					'Create Source subfolder as needed - ART, PM, DESIGN, CAD
					If Not(fso.FolderExists(aPath & flFolder1 & "\" & flFolder2 & "\" & flFolder3 & "\" & source)) Then
						AddNewSubFolder aPath & flFolder1 & "\" & flFolder2 & "\" & flFolder3, source                                                    
					End If
					Err.Clear					
					mvPath = aPath & flFolder1 & "\" & flFolder2 & "\" & flFolder3 & "\" & source & "\"
					fso.CopyFolder fl, mvPath, True
					'Verify Copy Completed, before Deleting Folder
					If (Err.Number = 0 Or Err.Number = 424) Then
						Err.Clear				
						fso.MoveFolder fl, bPath
						'Verify Delete was succesful or log error.
						If Not(Err.Number = 0) Then
							msg = msg & "Folder: " & flName & ". Had Error during Move,  Error Number: " & Err.Number & ", Error Description: " & Err.Description & vbNewLine & vbNewLine
							FldrError = 1
							Err.clear
						End If
					Else
						'Log Errors during Copy
						msg = msg & "Folder: " & flName & ". Had Error during Copy,  Error Number: " & Err.Number & ", Error Description: " & Err.Description & vbNewLine & vbNewLine
						FldrError = 1
						Err.clear
					End If	
				Else
					msg = msg & "File Name Error:  File Name is invalid. Verify project number is correct and Project Type is correct " & flName & vbNewLine & vbNewLine
					fldrError = 1
				End If			
			Else
				msg = msg & "Folder name contains an invalid character: " & flName & vbNewLine & vbNewLine
				fldrError = 1	
			End If
		End If
	Next
 
	If fldrError = 1 Then
		subject = "SAP " & source & " Archive Error Log"
		sendMail sender, recipients, subject, msg
		fldrError = 0	
	End If
Err.clear
End Sub
'
 
'Added source subfolder as needed
Sub AddNewSubFolder(path, subf)
	fso.CreateFolder(path & "\" & subf)
End Sub
 
'Add new folder
Sub AddNewFolders(num, path)
	Set ArchFolder = fso.GetFolder(path)
	Dim fc
	Set fc = ArchFolder.SubFolders
	fc.Add(num)
End Sub
 
'Sub to write folder error log to a text file to each archive location
Sub LogFolderError(msg, source)
	If (source = "CAD") Then
		cPath = CADPath & "CAD Error Log -" & Today & ".txt"
	ElseIf (source = "ART") Then
		cPath = ARTPath & "Art Error Log -" & Today & ".txt"
	ElseIf (source = "DESIGN") Then
		cPath = DesignPath & "Design Error Log -" & Today & ".txt"
	ElseIf (source = "PM") Then
		cPath = PMPath & "PM Error Log -" & Today & ".txt"
	End If
	Set rdFile = fso.OpenTextFile(cPath, 8, True)
	rdFile.Write msg
	rdFile.Close
End Sub
 
'List Folders Moved
Sub LogList(list, source, path)
	cPath = path & "Logs\" & source & " File List - " & Today & ".txt"
	Set rdFile = fso.OpenTextFile(cPath, 8, True)
	rdFile.Write list
	rdFile.Close
End Sub
 
Function sendMail(sender, recipients, subject, msg)
	Set Config = WScript.CreateObject("CDO.Configuration") 
	Set Message = WScript.CreateObject("CDO.Message") 
	Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
	Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.skyline.com" 
	Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 
	Config.Fields.Update
	Message.Configuration = Config 
	Message.To = recipients 
	Message.From = sender 
	Message.Subject = subject 
	Message.TextBody = msg 
	Message.Send 
End Function

Open in new window

0
Comment
Question by:jgoering
  • 2
3 Comments
 
LVL 29

Assisted Solution

by:Badotz
Badotz earned 100 total points
ID: 22667627
Do you get an error when the script is run?
Where exactly does the script fail?

As an aside, I don't see where you declare "f" in line 25. For that matter, you are remiss in declaring a great many variables throughout the script.
0
 
LVL 20

Accepted Solution

by:
ltlbearand3 earned 150 total points
ID: 22675073
Right off I don't see what could be stopping the deletion of the folder.  I assume your problem happens at:
fso.DeleteFolder path & "FolderBackup", true

Is it generating the email from the error?  I suggest adding

If Err<>"0" then msgbox Err.Description

after the fso.DeleteFolder and let us know what message is displayed.  This can help us diagnose the problem.

However, this may not be the problem.  As Badotz asked, do you know where the script fails?  If not, then I suggest temporarily commenting out "On Error Resume Next" at the beginning of the script to help find the problem.

-Bear
0
 
LVL 29

Expert Comment

by:Badotz
ID: 23124475
Grade "B" - was I bad?
0

Featured Post

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Recently I finished a vbscript that I thought I'd share.  It uses a text file with a list of server names to loop through and get various status reports, then writes them all into an Excel file.  Originally it was put together for our Altiris server…
This is an addendum to the following article: Acitve Directory based Outlook Signature (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_24950055.html) The script is fine, and works in normal client-server domains…
Windows 10 is mostly good. However the one thing that annoys me is how many clicks you have to do to dial a VPN connection. You have to go to settings from the start menu, (2 clicks), Network and Internet (1 click), Click VPN (another click) then fi…
Established in 1997, Technology Architects has become one of the most reputable technology solutions companies in the country. TA have been providing businesses with cost effective state-of-the-art solutions and unparalleled service that is designed…

813 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now