Save & delete old email macro - new guy need help

**sastoka** · 03-29-2017, 01:54 AM

Hi there,

I'm new to Outlook VBA.

While searching for a macro that could file and delete my emails I found this.

This is not mine.
Vbscript for Outlook emails backup and cleanup

gallery.technet.microsoft.com/scriptcenter/Vbscript-for-Outlook-ec13f44a

I keep getting an error

Compile Error
Invalide outside procedure

it's in the first few line, i've added a coment to locate it

I know a bit about excel macro and my guess is that i'm missing a declaration but absolutely not sure.

Is there any change someone can help me.

Many thanks.

PS: If for any reason this is not the right place to post this thread please let me know and i'll redo.

Option Explicit 
Dim strt, daysold
strt = Now  ' < THIS IS THE LINE THAT COMES OUT AS AN ERROR
Dim rootpath, path, foldr, strStoreName
Dim log, logline, strttime, endtime, status, foldcntr, closingnote, excludelist
Dim folder(75, 5)
foldcntr = 0
 
strStoreName = InputBox("Please enter the email address or display name as it appears in your Outlook", "Email id")
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 foldSub 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 Function
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 Function
        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 "<SCRIPT LANGUAGE=""VBScript"">"
objHTAFile.writeline "       Sub Window_OnLoad"
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 "</SCRIPT>"
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

**skatonni** · 03-30-2017, 01:31 PM

There are many sites where you can find VBA code. You did not find that code on one of them.

Option Explicit

Sub This_is_VBA()

    Dim strt
    strt = Now
    MsgBox "strt is: " & strt
    
End Sub

**sastoka** · 03-30-2017, 11:25 PM

OK thanks for the help.

By the way this is where i found the macro

https://gallery.technet.microsoft.com/scriptcenter/Vbscript-for-Outlook-ec13f44a

**gmayor** · 03-31-2017, 04:56 AM

The code you posted is not VBA but VB. The two are not quite the same and VB is not compatible with Outlook VBA.

Rather than spend hours converting the code to VBA, the following code will save ALL the messages in a selected folder to an EXISTING named folder on your hard drive - here "C:\Outlook Message Backup\".

The macro does not delete the messages in the folder. You can delete them when you are sure they have been saved to your satisfaction

The code includes a macro to test the process with a single selected message and you can use Sub SaveItem as a scipt associated with a rule to save the messages to your hard drive as they arrive.

Option Explicit
Private Const strPath As String = "C:\Outlook Message Backup\" 'The folder to save the messages

Sub TestMacro()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub SaveAllMessagesInFolder()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves all the messages in a selected Outlook folder
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim lngCount As Long: lngCount = 0
    Set olItems = Session.PickFolder.Items
    For Each olItem In olItems
        SaveItem olItem
        lngCount = lngCount + 1
        DoEvents
    Next olItem
    MsgBox "Saved " & lngCount & " messages to " & vbCr & strPath
    Set olItem = Nothing
    Set olItems = Nothing
lbl_Exit:
    Exit Sub
End Sub

Public Sub SaveItem(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 29/03/2017
'May be used as a script with an Outlook rule
Dim fname As String
If olItem.sender Like "*@gmayor.com" Then    'Your domain or in the case of an exchange account your account name
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(92), "-")
    fname = Replace(fname, Chr(124), "-")
    On Error GoTo err_handler
    SaveUnique olItem, strPath, fname
lbl_Exit:
    Exit Sub
err_handler:
    WriteToLog strPath & "Error Log.txt", strPath & fname
    Err.Clear
    GoTo lbl_Exit
End Sub

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 29/03/2017
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFileName)
    Do While fso.FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg", olMsg 'save as msg format
lbl_Exit:
    Exit Function
End Function

**sastoka** · 04-02-2017, 11:22 PM

HI there,

Thanks a lot.

Worked like a charme.

Really appreciate it.

Regards,

Thread: Save & delete old email macro - new guy need help

Thread Tools

Display

Save & delete old email macro - new guy need help

Posting Permissions