alexuplink
Newbie | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Для тех кто не удаляет спам а складывает его для дальнейшего анализа (например юзер позвонил сказав что почта не доходит).
Проблему решил таким образом: в каждом фильтре поставил галку "move to subfolder of user's mailbox" (туда письма сваливаются в формате {...}.eml), задал значение SPAM\<имяфильтра> + написал скрипт который копирует в спамоотстойник на сервере для дальнейшего удобного поиска. Скрипт в шедулер на каждые 15 (интервал, в принципе, любой) минут. Выходной формат: \\share\spam\<имяантиспамфильтра>\frommail_tomail_subject_guidpart.eml
В результате кириллица не "корявится".
'начало скрипта
'written by alex for russian-text mails
'this script for GFI ME only (tested with ver. 11)
Dim message
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("M:\mydomain.RU\MBX")
Set spamFolder_dest = objFSO.GetFolder("\\SHARE\SPAM\")
Set colSubfolders = objFolder.Subfolders
For Each objSubfolder in colSubfolders
If objFSO.FolderExists(objSubfolder & "\" & "SPAM") Then
Set spamFolder = objFSO.GetFolder(objSubfolder & "\" & "SPAM")
Set colSpamSubfolders = spamFolder.Subfolders
For Each spamsubFolder in colSpamSubfolders
For Each objFile in spamsubFolder.Files
DestName = spamFolder_dest & "\" & spamsubFolder.Name
If LCase(objFSO.GetExtensionName(objFile)) = "eml" Then
if Instr(objFSO.GetFileName(objFile), "@") > 0 Then
objFile.Move DestName & "\" & objFile.Name
End if
if Instr(objFile.Name, "{") > 0 AND Instr(objFile.Name, "}") > 0 Then
strLoad = spamsubFolder & "\" & objFile.Name
Set message = LoadMessageFromFile(strLoad)
if InStr(message.From,"@") > 0 AND InStr(message.To,"@") > 0 Then
GUIDpart_ = Left(objFile.Name,9)
GUIDpart=replace(GUIDpart_,"{","_",1)
if InStr(message.From,"<") = 0 Then
val_from = message.From
End if
if InStrRev(message.From,"<") > 0 AND InStrRev(message.From,">") > 0 Then
pos1_from=InStrRev(message.From,"<")
pos2_from=InStrRev(message.From,">")
diff = pos2_from - pos1_from -1
val_from = mid(message.From,pos1_from + 1,diff)
val_from=Trim(val_from)
End if
if InStr(message.To,"<") = 0 Then
val_to = message.To
End if
if InStrRev(message.To,"<") > 0 AND InStrRev(message.To,">") > 0 Then
pos1_to=InStrRev(message.To,"<")
pos2_to=InStrRev(message.To,">")
diff = pos2_to - pos1_to - 1
val_To = mid(message.To,pos1_to + 1,diff)
val_To=Trim(val_To)
End if
val_To=replace(val_To,"&","_",1)
val_To=replace(val_To," ","_",1)
val_To=replace(val_To,":","_",1)
val_To=replace(val_To,"\","_",1)
val_To=replace(val_To,"/","_",1)
val_To=replace(val_To,"<","_",1)
val_To=replace(val_To,">","_",1)
val_To=replace(val_To,"""","_",1)
val_To=replace(val_To,"'","_",1)
val_To=replace(val_To,"?","_",1)
val_To=replace(val_To,"|","_",1)
val_To=replace(val_To,"*","_",1)
message.subject = StripInvalidChrs (message.subject)
strNewName = val_from & "_" & val_To & "_" & message.subject & "_" & GUIDpart
if Len(DestName & "\" & strNewName) >= 254 Then
strNewName = Left(strNewName, 180)
End if
objFile.Move DestName & "\" & strNewName & ".eml"
Else if DateDiff("D", objFile.DateLastModified, Now) > 1 Then
objFile.Delete true
End if
End if
End if
End if
Next
Next
End if
Next
Function LoadMessageFromFile(Path) 'As Message
Dim Stm
Set Stm = CreateObject("ADODB.Stream")
Stm.Charset = "ascii"
Stm.Open
Stm.LoadFromFile Path
Dim iMsg
Set iMsg = CreateObject("CDO.Message")
Dim iDsrc
Set iDsrc = iMsg.GetInterface("IDataSource")
iDsrc.OpenObject Stm, "_Stream"
Set LoadMessageFromFile = iMsg
End Function
Function StripInvalidChrs (string)
If InStr(string, Chr(33)) > 0 Or InStr(string, Chr(34)) > 0 Or InStr(string, Chr(94)) > 0 Or InStr(string, Chr(96)) > 0 Then
string = Replace(Replace(Replace(Replace(string, Chr(33), ""), Chr(34), ""), Chr(94), ""), Chr(96), "_",1)
End if
for i = 1 to 31
If InStr(string, Chr(i)) > 0 Then
string = Replace(string, Chr(i), "_",1)
End If
Next
for i = 39 to 47
If InStr(string, Chr(i)) > 0 And i <> 45 Then
string = Replace(string, Chr(i), "_",1)
End If
Next
for i = 58 to 63
If InStr(string, Chr(i)) > 0 Then
string = Replace(string, Chr(i), "_",1)
End If
Next
If InStr(string, Chr(175)) > 0 Then
string = Replace(string, Chr(175), "_",1)
End if
If InStr(string, Chr(92)) > 0 Then
string = Replace(string, Chr(92), "_",1)
End if
for i = 152 to 182
If InStr(string, Chr(i)) > 0 Then
string = Replace(string, Chr(i), "_",1)
End If
Next
StripInvalidChrs = StripInvalidChrs & string
End Function
Set objFSO = Nothing
'конец скрипта |
Там по-моеиу всё, кроме записей keyword checking. Вскрыл antispam7.dll, думал мож там как ресурс эти строки есть, а нет там ничего
