Solved

What is causing this script to not delete new folders?

Posted on 2008-10-07
3
185 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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Script to copy or move mouse-selected collection of files plus targets referenced by shortcuts (.lnk) The purpose of this article is to help illuminate the real challenges and options available (where they may exist) for utilizing simple scriptin…
Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
It is a freely distributed piece of software for such tasks as photo retouching, image composition and image authoring. It works on many operating systems, in many languages.
You have products, that come in variants and want to set different prices for them? Watch this micro tutorial that describes how to configure prices for Magento super attributes. Assigning simple products to configurable: We assigned simple products…

758 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

20 Experts available now in Live!

Get 1:1 Help Now