See screen shot as example:
- SpamReport.jpg (92.19 KiB) Viewed 2686 times
Ensure you review and change ALL variables within the CONFIG section. Note: If there is more than one named Spam folder then it can be entered whilst separated with the PIPE | symbol.
eg,
Code: Select all
Const MESSAGES_FOLDER = "SPAM|Bulk"This allows to cover all accounts that may have different spam folder names.
SpamReport.vbs
Code: Select all
Option Explicit
' #### CONFIG START ####
Const MESSAGES_FOLDER = "SPAM" ' Folder to delete from, case insensitive. Multiple folders can be separated by PIPE | symbol
Const IMAP_DELIMITER = "." ' This needs to be same as what u used above for subfodlers based on delimiter
' setting in hmailserver
Const HMSADMINUSER = "Administrator" ' Admin username
Const HMSADMINPWD = "yoursecretpassword" ' Admin password
Const HMSSERVER = "localhost" ' hMailServer Server (DCOM)
Const FROM_EMAIL = "system@yourdomain.com" ' Replace this with the email address you want the Spam Report to come FROM
Const REPORT_TO_ADMIN = TRUE ' Admin receives copy of all users Spam Reports (TRUE or FALSE)
Const REPORT_TO_EMAIL = "admin@yourdomain.com" ' Replace this with the ADMIN email address you want the Spam Report to be sent a copy to
' #### CONFIG END ####
' Objects
Dim oApp, oDomains, oDomain, oAccounts, oAccount, oMessages, oMessage
' Numeric
Dim NumMsgs, NumChecked, x, y, z, MessageID
' Strings / arrays
Dim SearchFolders, FindFolders, FoundFolder, AtLeastFound, FolderList, aFolder, SpamFolder
Dim Message, CreateGUIDval, OutputMsg, OutputMsgList, w, FolderArray, SplitCount, xFolder
' Flags
Dim ReturnValue : ReturnValue = 0
' On Error Resume Next
SearchFolders = Split(MESSAGES_FOLDER, "|")
Set oApp = CreateObject("hMailServer.Application", HMSSERVER)
Call oApp.Authenticate(HMSADMINUSER, HMSADMINPWD)
For x = 0 To oApp.Domains.Count - 1
Set oDomain = oApp.Domains.Item(x)
If oDomain.Active Then
For y = 0 To oDomain.Accounts.Count - 1
Set oAccount = oDomain.Accounts.Item(y)
If oAccount.Active Then
AtLeastFound = False
Set Message = CreateObject("hMailServer.Message", HMSSERVER)
OutputMsgList = ""
NumChecked = 0
For Each SpamFolder in SearchFolders
NumMsgs = 0
NumChecked = 0
Set FindFolders = oAccount.IMAPFolders
FoundFolder = False
FolderList = ListFolders(FindFolders, 0, "")
aFolder = Split(Left(FolderList, Len(FolderList) - 1), "|")
For Each z in aFolder
If UCase(z) = UCase(Trim(SpamFolder)) Then
AtleastFound = True
FoundFolder = True
SpamFolder = z
Exit For
End If
Next
If FoundFolder Then
Set oMessages = GetInsideFolders(oAccount.IMAPFolders, SpamFolder)
Do While oMessages.Count > (NumChecked)
Set oMessage = oMessages.Item(NumChecked)
NumMsgs = oMessages.Count
NumChecked = NumChecked + 1
If CLng(oMessage.ID) > 0 Then
OutputMsgList = OutputMsgList & "<tr><td>" & oMessage.FromAddress & "</td>"
OutputMsgList = OutputMsgList & "<td>" & mid(oMessage.Date,6,20) & "</td>"
OutputMsgList = OutputMsgList & "<td>" & oMessage.Subject & "</td></tr>" & vbcrlf
End If
Loop
End If
Next
If AtLeastFound then
OutputMsg = "<font face=""Calibri"">Account: " & oAccount.Address & "<br><br>The following " & NumChecked & _
" messages are currently held in your Spam mail folder """ & MESSAGES_FOLDER & """.<br><br>"
If NumChecked > 0 then
OutputMsg = OutputMsg & "<table><tr><td width=350><b>From</b></td><td><b>Date</b></td><td><b>Subject</b></td></tr>" & vbCrLf & OutputMsgList & vbcrlf
OutputMsg = OutputMsg & "</table>" & vbCrLf
End If
Else
OutputMsg = "<tr>""" & MESSAGES_FOLDER & """ folder Not Found in account " & oAccount.Address & "</tr>"
End If
Message.HeaderValue("Message-ID") = "<" & CreateGUID & ">"
Message.FromAddress = FROM_EMAIL
Message.From = "Spam Report Daemon <"& FROM_EMAIL & ">"
If REPORT_TO_ADMIN then
Message.AddRecipient "System Administrator", REPORT_TO_EMAIL
End If
Message.AddRecipient oAccount.Address , oAccount.Address
Message.Subject = "Spam Report - " & oAccount.Address
Message.HTMLBody = OutputMsg
Message.Save
End If
Next
End If
Next
Wscript.Quit ReturnValue
Function ShowError(strMessage)
WScript.Echo strMessage
WScript.Echo Err.Number & " Srce: " & Err.Source & " Desc: " & Err.Description
ReturnValue = Err.Number
Err.Clear
End Function
Function ListFolders(obFolders, iRecursion, rootFolder)
iRecursion = iRecursion + 1
Dim sMessage
Dim i
For i = 0 To obFolders.Count -1
Dim obFolder
Set obFolder = obFolders.Item(i)
If iRecursion > 1 Then
FolderArray = Split(rootFolder, IMAP_DELIMITER)
SplitCount=0
for each xFolder in FolderArray
SplitCount=SplitCount+1
if SplitCount < iRecursion then
if SplitCount = 1 then
rootFolder = xFolder
else
rootFolder = rootFolder & IMAP_DELIMITER & xFolder
end if
else
if SplitCount = iRecursion then
Exit for
End if
end if
next
sMessage = sMessage & rootFolder & IMAP_DELIMITER & obFolder.Name & "|"
Else
sMessage = sMessage & obFolder.Name & "|"
End If
If iRecursion = 1 Then
rootfolder =obFolder.Name
Else
rootFolder = rootFolder & IMAP_DELIMITER & obFolder.Name
End If
sMessage = sMessage & ListFolders(obFolder.SubFolders, iRecursion, rootFolder )
Next
iRecursion = iRecursion -1
ListFolders = sMessage
End Function
Function GetInsideFolders(obFolders2, subFolders)
Dim iRecursion2
iRecursion2 = 1
Dim SeprateFodlers
SeprateFodlers = Split(subFolders, IMAP_DELIMITER)
For Each w in SeprateFodlers
If iRecursion2 = 1 Then
Set obFolders2 = obFolders2.ItemByName(w)
iRecursion2 = iRecursion2 + 1
Else
Set obFolders2 = obFolders2.SubFolders.ItemByName(w)
End If
Next
Set GetInsideFolders = obFolders2.Messages
End Function
Function CreateGUID()
' Generate a random string.
With CreateObject("hMailServer.Utilities", HMSSERVER)
CreateGUID = Mid(.GenerateGUID, 2, 36) & "@randommail"
End With
End Function