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
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