'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
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
From novice to tech pro — start learning today.
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