The code below functions as designed, but I would like to modify it to
1)Get the emails in specified sub folders
2) Put those emails in a folder named just like the one they came from i.e. if the email comes from a subfolder of the inbox named "personal" then I want the folder the email is saved in name "personal"
The second block of code would be perfect if I could get it to work, but I keep getting errors on things like "strt = now" with the error being "Invalid outside procedure". The same error occurs on "strStoreName = InputBox("Please Enter Timeframe")". Here is where that code came from: https://gallery.technet.microsoft.com/office/Vbscript-for-Outlook-ec13f44a
1)Get the emails in specified sub folders
2) Put those emails in a folder named just like the one they came from i.e. if the email comes from a subfolder of the inbox named "personal" then I want the folder the email is saved in name "personal"
The second block of code would be perfect if I could get it to work, but I keep getting errors on things like "strt = now" with the error being "Invalid outside procedure". The same error occurs on "strStoreName = InputBox("Please Enter Timeframe")". Here is where that code came from: https://gallery.technet.microsoft.com/office/Vbscript-for-Outlook-ec13f44a
Code:
Function RemoveIllegalCharacters(strValue As String) As String
RemoveIllegalCharacters = strValue
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function
Sub OpenAndSave()
Dim strNewFolderName As String
strNewFolderName = InputBox("Input Reference Number - For Example 12345")
If Len(Dir("U:\" & strNewFolderName, vbDirectory)) = 0 Then
MkDir ("U:\" & strNewFolderName)
End If
Dim save_to_folder As String
'U:\Programs\WAM emails
save_to_folder = "U:\" & strNewFolderName
Dim olkMsg As Outlook.MailItem, intCount As Integer
intCount = 1
For Each olkMsg In Outlook.ActiveExplorer.Selection
olkMsg.Display
olkMsg.SaveAs save_to_folder & "\" & "Message #" & intCount & " " & RemoveIllegalCharacters(olkMsg.Subject) & ".msg"
olkMsg.Close olDiscard
intCount = intCount + 1
Next
Set olkMsg = Nothing
End Sub
Code:
Option Explicit
Dim strt 'daysold
Set strt = Now
Dim daysold
Dim rootpath, path, foldr, strStoreName As String
Dim log, logline, strttime, endtime, status, closingnote, excludelist '(foldcntr,)Moved to separate line
Dim folder(75, 5)
Dim foldcntr As Integer
Set foldcntr = 0
strStoreName = InputBox("Please Enter Timeframe")
If strStoreName = "" Then
MsgBox "Invalid email, please re-run the script"
wscript.Quit
End If
rootpath = InputBox("Please enter the path to save the emails", "Path")
If rootpath = "" Then
MsgBox "Invalid path, please re-run the script"
wscript.Quit
End If
folder_exist (rootpath)
rootpath = rootpath & "\"
daysold = InputBox("Please enter the number of days", "Older than days")
If daysold = "" Then
MsgBox "Invalid number, please re-run the script"
wscript.Quit
ElseIf Not IsNumeric(daysold) Then
MsgBox "Please enter number only, please re-run the script"
wscript.Quit
End If
If MsgBox("Do you want to exclude any folder(s) ?", 36, "Confirmation") = vbYes Then
excludelist = LCase(InputBox("To exclude any folder(s), please enter folder name as it appears in outlook separated by comma "","" ", "Feed-in"))
End If
If MsgBox("Are you sure you want to proceed ?", vbYesNo, "confirmation") = vbNo Then
wscript.Quit
End If
MsgBox "If you want to stop this process, please open Task Manager and kill ""wscript.exe"" under processes tab ", vbInformation, "Alert"
strttime = Now
'Other declarations
Dim objOutlook, objNamespace, objStore, objRoot, objInbox, objSentItems
Dim objFSO, objHTAFile, objshell, objLOGFile, mailbody
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objStore = objNamespace.Stores.Item(strStoreName)
Set objRoot = objStore.GetRootFolder()
Set objInbox = objRoot.Folders("Inbox")
Set objSentItems = objRoot.Folders("Sent Items")
Dim objWorkingFolder, foldname
Dim colitems, olMsg, cnt
Dim objInputFile, size
olMsg = 3
'************ Call the function to save the email
Create_HTA_FILE
Set objshell = CreateObject("Wscript.Shell")
objshell.Run ".\status1.hta"
Create_Log_File
mailbody = "Outlook backup and clean-up tool has Started will send out an completion email, please do not run another instance"
SendEmail "Outlook backup and clean-up has Started : " & strttime, mailbody
wscript.sleep "5000"
SaveEmail
Set objshell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objInputFile = objFSO.OpenTextFile("log.ini", 1)
mailbody = objInputFile.readall
objInputFile.Close
SendEmail "Outlook backup and clean-up has Finished : " & endtime, mailbody
Set objWorkingFolder = Nothing
Set objInbox = Nothing
Set objRoot = Nothing
Set objStore = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Set objSentItems = Nothing
MsgBox " emails are saved in location " & vbCr & rootpath, vbSystemModal, "Task Completed Successfully"
wscript.Quit
Public Function SaveEmail()
path = rootpath & Trim(objInbox) & "\"
folder_exist (path)
cnt = objInbox.Items.Count
Set colitems = objInbox.Items
objWorkingFolder = objInbox.Name
foldname = objInbox.Name
SaveAndDeleteEmails()
Set colitems = Nothing
Dim objSubFolder
For Each objSubFolder In objInbox.Folders
path = rootpath & objInbox & "\" & Trim(objSubFolder) & "\"
folder_exist (path)
cnt = objSubFolder.Items.Count
Set colitems = objSubFolder.Items
objWorkingFolder = objInbox.Name & "\" & objSubFolder.Name
foldname = LCase(objSubFolder.Name)
SaveAndDeleteEmails()
Set colitems = Nothing
If objSubFolder.Folders.Count > 1 Then
Dim fold
For Each fold In objSubFolder.Folders
path = rootpath & objInbox & "\" & Trim(objSubFolder) & "\" & Trim(fold) & "\"
folder_exist (path)
cnt = fold.Items.Count
objWorkingFolder = objInbox.Name & "\" & objSubFolder.Name & "\" & fold.Name
foldname = LCase(fold.Name)
Set colitems = fold.Items
SaveAndDeleteEmails()
Set colitems = Nothing
Next
End If
Next 'folders loop
'*************** For Sent items
path = rootpath & Trim(objSentItems) & "\"
folder_exist (path)
cnt = objSentItems.Items.Count
Set colitems = objSentItems.Items
objWorkingFolder = objSentItems.Name
foldname = LCase(objSentItems.Name)
SaveAndDeleteEmails()
closingnote = "<BR><B>Outlook backup and clean-up script has completed, you may now close this window</B><BR>"
status = "<span style=""background-color: #90EE90"">Finished</span>"
endtime = Now
Create_Log_File
Set objSubFolder = Nothing
Set fold = Nothing
End Function
Sub SaveAndDeleteEmails()
foldcntr = foldcntr + 1
folder(foldcntr - 1, 0) = objWorkingFolder
folder(foldcntr - 1, 1) = cnt
folder(foldcntr - 1, 2) = "-"
folder(foldcntr - 1, 3) = "-"
folder(foldcntr - 1, 4) = "Processing"
status = "<span style=""background-color: #FFFF00"">Running</span>"
endtime = "Running"
Create_Log_File
If InStr(excludelist, foldname) <> 0 Then
folder(foldcntr - 1, 2) = "0"
folder(foldcntr - 1, 3) = "0"
folder(foldcntr - 1, 4) = "<span style=""background-color: #E6E6FA"">Excluded</span>"
Create_Log_File
Exit Sub
End If
Dim counter
counter = 0
If Not cnt = 0 Then
Dim i
Dim filename, tempfilename, fsize
For i = cnt To 0 Step -1
If colitems(i).ReceivedTime < DateAdd("d", -daysold, Now) Then
filename = colitems(i).Subject & " " & colitems(i).ReceivedTime & ".msg"
tempfilename = CleanString(filename)
fsize = fsize + colitems(i).size
On Error Resume Next
colitems(i).SaveAs path & tempfilename, olMsg
colitems(i).Delete
counter = counter + 1
Else
Exit For
End If
folder(foldcntr - 1, 2) = counter
folder(foldcntr - 1, 3) = Int((fsize / 1024))
Create_Log_File
Next
End If
folder(foldcntr - 1, 2) = counter
folder(foldcntr - 1, 3) = Int((fsize / 1024))
folder(foldcntr - 1, 4) = "Finish"
size = size + fsize
Create_Log_File
End Sub
Function Create_HTA_FILE()
'on error resume next
Set objFSO = CreateObject("Scripting.FilesystemObject")
Set objHTAFile = objFSO.OpenTextFile(".\status1.hta", 2, True)
objHTAFile.writeline "<html>"
objHTAFile.writeline "<head>"
objHTAFile.writeline "<H2>Status of the outlook emails backup and clean-up script</H2>"
objHTAFile.writeline "<title>Status - Auto Refreshed</title>"
objHTAFile.writeline "<HTA:APPLICATION "
objHTAFile.writeline " ID=""objAutoRefresh"""
objHTAFile.writeline " APPLICATIONNAME=""Status - Auto Refreshed"""
objHTAFile.writeline " SCROLL=""auto"""
objHTAFile.writeline " SINGLEINSTANCE=""yes"""
objHTAFile.writeline ">"
objHTAFile.writeline "</head>"
objHTAFile.writeline "******** LANGUAGE=""VBScript"">"
objHTAFile.writeline " Sub Window_******"
objHTAFile.writeline " RefreshList "
objHTAFile.writeline " iTimerID = window.setInterval(""RefreshList"", 1000)"
objHTAFile.writeline " End Sub"
objHTAFile.writeline " Sub RefreshList"
objHTAFile.writeline " strHTML="""""
objHTAFile.writeline " Set objShell = CreateObject(""WScript.Shell"") "
objHTAFile.writeline " Set objFSO = CreateObject(""Scripting.FileSystemObject"")"
objHTAFile.writeline " Set objInputFile= objFSO.OpenTextFile(""log.ini"",1)"
objHTAFile.writeline " strHTML= objInputFile.readall"
objHTAFile.writeline " objInputFile.close"
objHTAFile.writeline " ProcessList.InnerHTML = strHTML"
objHTAFile.writeline " End Sub"
objHTAFile.writeline "*********>"
objHTAFile.writeline "<body><span id = ""ProcessList""></span>"
objHTAFile.writeline "</body>"
objHTAFile.writeline "<sub>"
objHTAFile.writeline "-- <BR>"
objHTAFile.writeline "Scripted by Somesh</sub>"
objHTAFile.writeline "</html>"
objHTAFile.Close
Set objFSO = Nothing
Set objHTAFile = Nothing
End Function
Function Create_Log_File()
Set objFSO = CreateObject("Scripting.FilesystemObject")
Set objLOGFile = objFSO.OpenTextFile(".\log.ini", 2, True)
objLOGFile.writeline "<PRE style=""font-family:calibri;font-size:16px;"">Email account : <B>" & strStoreName
objLOGFile.writeline "</B><BR>Start time : " & strttime
objLOGFile.writeline "<BR>Status : " & status
objLOGFile.writeline "<BR>End time : " & endtime
objLOGFile.writeline "<BR>Path : " & rootpath
objLOGFile.writeline "<BR>Number of days old emails to backup : " & daysold
objLOGFile.writeline "<BR>Total Size freed up (Kb) : " & (size / 1024)
objLOGFile.writeline "</PRE><BR><Table border=""1""><style=""font-family:Times New Roman;""><TR><TD>Folder Name</TD><TD>Total emails </TD><TD>Processed</TD>" _
& "<TD>Size saved(Kb)</TD><TD>Status</TD></TR></TR>"
Dim i
For i = 0 To foldcntr - 1
objLOGFile.writeline "<TR>"
objLOGFile.writeline "<TD>" & folder(i, 0)
objLOGFile.writeline "</TD><TD>" & folder(i, 1)
objLOGFile.writeline "</TD><TD>" & folder(i, 2)
objLOGFile.writeline "</TD><TD>" & folder(i, 3)
objLOGFile.writeline "</TD><TD>" & folder(i, 4)
objLOGFile.writeline "</TR>"
Next
objLOGFile.writeline "</Table>"
objLOGFile.writeline closingnote
Set objFSO = Nothing
Set objLOGFile = Nothing
End Function
Function folder_exist(path)
On Error Resume Next
Set objshell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not (objFSO.FolderExists(path)) Then
objFSO.CreateFolder path
End If
End Function
Function CleanString(strData)
'Replace invalid strings.
strData = Replace(strData, "´", "'")
strData = Replace(strData, "`", "'")
strData = Replace(strData, "{", "(")
strData = Replace(strData, "[", "(")
strData = Replace(strData, "]", ")")
strData = Replace(strData, "}", ")")
strData = Replace(strData, " ", " ") 'Replace two spaces with one space
strData = Replace(strData, " ", " ") 'Replace three spaces with one space
'Cut out invalid signs.
strData = Replace(strData, ": ", "_") 'Colan followded by a space
strData = Replace(strData, ":", "_") 'Colan with no space
strData = Replace(strData, "/", "_")
strData = Replace(strData, "\", "_")
strData = Replace(strData, "*", "_")
strData = Replace(strData, "?", "_")
strData = Replace(strData, """", "'")
strData = Replace(strData, "<", "_")
strData = Replace(strData, ">", "_")
strData = Replace(strData, "|", "_")
CleanString = Trim(strData)
End Function
Last edited: