JohnRD
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
добрый день
есть необходимость вытаскивать вложения c оригинальным именем из почтового ящика на hmailserver и класть их в папку для дальнейшей обработки
я нашел скрипт на родном форуме но есть недочеты,
1. если вложений больше 1го то он сохраняет только одно первое по списку, но интересно: делает ровно столько операций - сколько вложений но перезаписывает один и тот же
вот лог
logFileHmailServer.txt
Код:
===== Log Entry For: C:\Program Files\hMailServer\Data\{F1505E96-30A8-47AF-B3BA-4F622B53F831}.eml - 17.12.2008 5:21:09=====
Recipients Matches: info@domain.ru
Extension Check: True
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
Extension gefunden: .xml
*** Storing File --- filename: E:\install\GetMail\22\80020_1901067718_20081202_1624.xml
|
2 недочет это: чтобы задать тип файла для сохранения нужно в конфиге создать один фейковый тип последним в списке, последний он почему то игнорирует
вот конфиг:
list.csv
Код:
# Felder die durch ";" getrennt sind
# 1) EmailAdresse (Pflichtfeld)
# 2) AttachmentEndung * = alle, ansonsten *.txt,*.zip (Pflichtfeld)
# 3) Logging true or false (Pflichtfeld)
# 4) Directory in welchen Directory es gepeichert werden muss. (Optional)
# 5) Overwrite existing files true or false (Pflichtfeld)
# Beispiele:
#maila@domain.de;.txt;true;Folder1\;true;
#maila@domain.de;*.txt,*.zip,*.asp;true;Folder2\;false;
#mailb@domain.com;*.txt,*.zip;false;;true;
# WICHTIG: AM Anfang keine ";" am Ende ein ";"
#maila@domain.de;.txt;true;Folder1\;true;
#maila@domain.de;*.txt,*.zip,*.asp;true;Folder2\;false;
#mailb@domain.com;*.txt,*.zip;false;;true;
info@domain.ru;*.rar,*.xml,*.zip,*.asp;true;22\;true; ---> фэйковый тип asp
|
вот сам скрипт:
EventHandlers.vbs
Код:
' Sub OnClientConnect(oClient)
' End Sub
' Sub OnAcceptMessage(oClient, oMessage)
' End Sub
' Sub OnDeliveryStart(oMessage)
' End Sub
' Sub OnDeliverMessage(oMessage)
' End Sub
' Sub OnBackupFailed(sReason)
' End Sub
' Sub OnBackupCompleted()
' End Sub
Option Explicit
'***********************************************
'* Script zur automatischen Speicherung von Attachments
'***********************************************
Sub OnAcceptMessage(oClient, oMessage)
' Script
Dim fs ' Fielsystem Objekt
Dim cPath ' Der Pfad wo alles bespeichert wird
Dim attachCount ' Counter fur die Attachments
Dim logger ' File in die das Logfile des Script geschrieben werden
Dim dBug ' DBug Message ausgeben
Dim DBugMeldung ' Debug Meldungen
Dim i,j,k,l ' Counter
Dim msgFile ' Name der Email
Dim logFile ' Name des Logfiles
Dim doLogging ' Soll mit Geloggt werden
Dim cMailDirectory ' Directory in das die Attachments gespeichter werden
Dim cConfiFile ' File in dem beschrieben ist was bei welcher Email Adresse passiert
Dim oFile ' FielsystemObjekt
Dim cLine ' ConfigFile Zeile
Dim aTemp ' Temporares Array
Dim aExtensionArray ' Array falls verschiedene Exstesnions betrachtet werden mussen
ReDim aConfigArray(4,0) ' AktionenProEmail
Dim bExtensionArray ' Berucksichtigende Erweiterungen?
Dim bExtensionFound ' Extension Found
Dim cTempFileName ' File name falls er schon vorhanden ist
cPath = "E:\install\GetMail\"
cConfiFile = cPath & "list.csv"
logFile = "logFileHmailServer.txt"
dBug = true
Set fs = CreateObject("Scripting.FileSystemObject")
If dBug Then
Set DBugMeldung = fs.OpenTextFile(cPath & "Debug.txt", 8, True)
DBugMeldung.Writeline("--- New Message ---")
DBugMeldung.Writeline(Now()& " - Script Started")
End If
' Config File einlesen:
If dBug Then
DBugMeldung.Writeline(Now() & " - The Following Config File will be readin:" & cConfiFile)
End If
Set oFile = fs.OpenTextFile(cConfiFile, 1, False)
i = 0
Do While oFile.AtEndOfLine <> True
cLine = oFile.ReadLine
If dBug Then
DBugMeldung.Writeline(Now() & " - ReadLine: " & cLine) & "- Array Fields" & ubound(Split(cLine,";"),1)
End If
If Mid(cLine, 1, 1) <> "#" and 5 = ubound(Split(cLine,";"),1) Then
If dBug Then
DBugMeldung.Writeline(Now() & " - Correct Line Found: " & cLine)
End If
ReDim Preserve aConfigArray(4, i + 1)
aTemp = Split(cLine,";")
'Empfanger Adresse
aConfigArray(0,i) = aTemp(0)
' Attachment Extension
aConfigArray(1,i) = aTemp(1)
'Logging
aConfigArray(2,i) = aTemp(2)
'Directory
aConfigArray(3,i) = aTemp(3)
'Overwrite Existing File
aConfigArray(4,i) = aTemp(4)
i = i + 1
End If
loop
Set oFile = Nothing
If dBug Then
DBugMeldung.Writeline(Now() & " - Email List was Readin")
End If
msgFile = oMessage.Filename
' Nur Ausfuhren Falls Attachment vorhanden sind
If oMessage.Attachments.Count > 0 Then
If dBug Then
DBugMeldung.Writeline(Now() & " - Attachment found")
End If
'it has attachments, so we'll take action
For j=0 to UBound(aConfigArray,2) - 1
If dBug Then
DBugMeldung.Writeline ""
DBugMeldung.Writeline(Now() & " - Adresse: " & aConfigArray(0,j))
DBugMeldung.Writeline(Now() & " - Extension: " & aConfigArray(1,j))
DBugMeldung.Writeline(Now() & " - Logging: " & aConfigArray(2,j))
DBugMeldung.Writeline(Now() & " - Directory: " & aConfigArray(3,j))
DBugMeldung.Writeline(Now() & " - Overwrite File: " & aConfigArray(4,j))
DBugMeldung.Writeline ""
DBugMeldung.Writeline(Now() & " - Anzahl Empfanger" & oMessage.Recipients.Count)
End If
For i = 0 To oMessage.Recipients.Count - 1
If dBug Then
DBugMeldung.Writeline(Now()& " - Compare Empfanger:" & aConfigArray(0,j) & " = " & oMessage.Recipients(i).Address & "== Ergebniss ==>" & InStr(1,aConfigArray(0,j),oMessage.Recipients(i).Address, 1 ))
End If
If InStr(1,aConfigArray(0,j),oMessage.Recipients(i).Address, 1 ) > 0 Then
If LCase(aConfigArray(2,j)) = "false" Then
doLogging = false
Else
doLogging = true
End if
' In welches Directory muss die Emial gespeichert werden
cMailDirectory = aConfigArray(3,j)
If Len(Trim( cMailDirectory )) <= 0 Then
cMailDirectory = Replace(Replace(Replace(aConfigArray(0,j),"@","_at_"),".","_")," ","_") & "\"
End If
If not(fs.FolderExists(cPath & cMailDirectory)) Then
fs.CreateFolder(cPath & cMailDirectory)
End If
' Muss der Empafng Protokolliert werden
If doLogging Then
Set logger = fs.OpenTextFile(cPath & cMailDirectory & logFile, 8, True)
logger.WriteLine("===== Log Entry For: " & msgFile & " - " & Now() & "=====")
logger.WriteLine("Recipients Matches: " & aConfigArray(0,j))
End If
'Extension Array Aufbereiten
If Len(aConfigArray(1,j)) > 1Then
If InStr(1,aConfigArray(1,j),",") = 0 Then
aConfigArray(1,j) = aConfigArray(1,j) & ","
End If
aExtensionArray = Split(aConfigArray(1,j),",")
For k = 0 to UBound(aExtensionArray,1)
aExtensionArray(k) = Replace(aExtensionArray(k),"*","")
DBugMeldung.Writeline "xxxxx" & aExtensionArray(k)
Next
bExtensionArray = true
If doLogging Then
logger.WriteLine("Extension Check: True")
End If
If dBug Then
DBugMeldung.Writeline(Now()& " - Extensions vergleichen, Angaben - " & bExtensionArray)
End If
Else
bExtensionArray = false
If dBug Then
DBugMeldung.Writeline(Now()& " - Extensions nicht vergleichen, keine Angaben - " & bExtensionArray)
End If
End If
attachCount = oMessage.Attachments.Count
For l = 0 To attachCount - 1
If bExtensionArray Then
bExtensionFound = false
For k = 0 to UBound(aExtensionArray,1)-1
If dBug Then
DBugMeldung.Writeline(Now()& " - Vergleich von " & oMessage.Attachments(i).Filename & " mit " & aExtensionArray(k))
End If
If InStr(1,Right(oMessage.Attachments(i).Filename,Len(aExtensionArray(k))),aExtensionArray(k),1) > 0 Then
bExtensionFound = true
If doLogging Then
logger.WriteLine("Extension gefunden: " & aExtensionArray(k))
End If
If dBug Then
DBugMeldung.Writeline(Now()& " - Extension gefunden: " & aExtensionArray(k))
End If
End If
Next
End If
If not(bExtensionArray) or bExtensionFound Then
cTempFileName = cPath & cMailDirectory & oMessage.Attachments(i).Filename
If LCase(aConfigArray(4,j)) = "true" Then
oMessage.Attachments(i).SaveAs cTempFileName
Else
Do While fs.FileExists(cTempFileName)
If doLogging Then
logger.WriteLine("File Exist: " & cTempFileName)
End If
cTempFileName = cPath & cMailDirectory & Replace(Replace(Replace(Now(),":","_"),".","_")," ","_") & "_" & oMessage.Attachments(i).Filename
If doLogging Then
logger.WriteLine("Try a new Filename: " & cTempFileName)
End If
If dBug Then
DBugMeldung.WriteLine("File Exist try a new Filename: " & cTempFileName)
End If
loop
oMessage.Attachments(i).SaveAs cTempFileName
End If
If doLogging Then
logger.WriteLine("*** Storing File --- filename: " & cTempFileName)
If dBug Then
DBugMeldung.Writeline(Now()& " - File " & cTempFileName)
End If
End If
End If
Next
If doLogging Then
logger.Close()
Set logger = Nothing
End If
End If
Next
Next
End If
If dBug Then
DBugMeldung.Close()
Set DBugMeldung = Nothing
End If
Set fs = Nothing
' set Result.Value = 0 so that the message is queued for delivery (according to hMailServer Docs
Result.Value = 0
End Sub
|
если кто силен в vbs помогите пожалуйста устранить эти недочеты
на родном сайте я пытался описать проблему но как то неочень согласились помочь либо я не првильно описал аглиский же..
так скрипт работает хорошо, использую в продуктиве, но есть большая необходимость сохранять все вложения с оригинальными именами.
спасибо за помощь
|
