Outlook VBA to Copy Email to Drive + BONUS code (if you dare)

[adavid]

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

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

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

 

[RickXL]

The second block of code is not VBA. It is VBScript. You don't need Excel to run that.

If you have a Windows PC, just put the VBScript into a .txt file that you created with, say, Notepad and then rename it to end in .vbs. You can then double-click the file to run it.