Тема: VBScript: получение почты по POP3
Скрипт получения почты с POP-серверов (тестировался на bk.ru, mail.ru, rambler.ru) на "низком" уровне (никакой почтовый клиент не нужен).
Для запуска задайте нужные значения переменным MailServer, MailPort_POP3, User, Password в начале скрипта. Скачанные письма записываются в формате .eml (открываются двойным щелчком в Outlook Express) в папку, которая создаётся там же, где лежит сам скрипт, и сортируются по датам. Для работы нужен MSWINSCK.OCX (должен идти вместе с MS Office, VB6).
Public Wsock
Public Connected
Public Recieved
Public Action
Public CurrentLetter
Public LOG_FILE
Public STARTT
HOST_EXE=Wscript.FullName
VBS=WScript.ScriptFullName
VBS_Name=WScript.ScriptName
If InStr(1,HOST_EXE,"wscript.exe",1) Then
HOST_EXE=Replace(HOST_EXE,"wscript.exe","cscript.exe",1,1,1)
WScript.CreateObject("WScript.Shell").Run HOST_EXE & " //NOLOGO " & VBS,1,False
Wscript.Quit
End If
WHERE_WE=Replace(VBS,"\" & VBS_NAME,"")
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
WHERE_WRITE=CreateArxiv(WHERE_WE)
LOG_FILE=WHERE_WRITE & "\SESSION.LOG"
On Error Resume Next
Set LOG_FILE = fso.OpenTextFile(LOG_FILE , 8, True)
If Err.Number<>0 Then
MsgBox "Не создать файл " & LOG_FILE
Wscript.Quit
End If
On Error GoTo 0
MailServer = "pop.mail.ru"
MailPort_POP3 = 110
User="USER"
Password="PASSWORD"
Recieve_Mail MailServer,MailPort_POP3,User,Password,WHERE_WRITE
'---------------Функции и процедуры---------------------
Sub Recieve_Mail(MailServer,MailPort_POP3,User,Password,WHERE_WRITE)
On Error GoTo 0
CurrentLetter=0
Set Wsock = Wscript.CreateObject("MSWinsock.Winsock", "WsockR_")
WriteLog "iMail","Объект создан..."
Wsock.Connect MailServer, MailPort_POP3
STATUS=Wait("Connect_Server")
If STATUS="Wsock.State=9" Then
WriteLog "iMail","Не подключиться к серверу. " & STATUS
Exit Sub
End If
WriteLog "iMail","Подключились к серверу " & MailServer & "..."
Wsock_SendData ("USER " & User & vbcrlf)
Wait "+"
Wsock_SendData ("PASS " & Password & vbcrlf)
Wait "+"
Wsock_SendData ("STAT" & vbcrlf)
Letters=Wait("+")
Letters=NUM((Mid(Letters,5)))
If Letters=0 Then
Wsock_SendData "QUIT" & vbCrLf
Wsock.Close
Set Wsock=Nothing
WriteLog "iMail","Писем нет "
Exit Sub
End If
For i=1 To Letters
CurrentLetter=fso.GetFolder(WHERE_WRITE).Files.Count 'Timer*100
If CurrentLetter=0 Then CurrentLetter=1
WriteLog "iMail","Запрос на получение " & i & "-го письма"
Wsock_SendData ("RETR " & i & vbcrlf)
Wait "LETTER"
WriteLog "iMail","Записали в файл " & i & "-е письмо"
CurrentLetter=0
'Если удалить письмо из ящика
'WriteLog "iMail","Запрос на удаление " & i & "-го письма"
'Wsock_SendData ("DELE " & i & " " & vbcrlf)
'Wait "DELETE"
'WriteLog "iMail","Удалили " & i & " письмо"
Next
CurrentLetter=0
Wsock_SendData "QUIT" & vbCrLf
Wait "QUIT"
Wsock.Close
Set Wsock=Nothing
End Sub
Sub Wsock_SendData (WHAT)
On Error Resume Next
Wsock.SendData (WHAT)
If Err.Number<>0 Then
WriteLog "iMail","Wsock.SendData(" & WHAT & ")=ERROR(" & Err.Number & ":" & Err.Description & ")"
ExitIt
End If
On Error GoTo 0
End Sub
Sub Wsock_Error(Number, Description, Scode, Source, _
HelpFile, HelpContext, CancelDisplay)
WriteLog "iMail","Внутреняя ошибка " & Number & ":" & Description
Wsock.Close
Set Wsock=Nothing
ExitIt
End Sub
Sub Wsock_Connect()
Action="Connected"
End Sub
Sub WsockR_DataArrival(ByVal reqid)
STARTT=Now()
Wsock.GetData RC ,8
If CurrentLetter=0 Then
WriteLog "iMail","From server " & RC
End If
'Технология с серого форума
If CurrentLetter<>0 Then
strRepeatingText="Saving e-Mail in File " & CurrentLetter & ".eml "
Wscript.StdOut.Write Chr(13) & strRepeatingText & Time()
End If
If Instr(1,RC,"-ERR") Then
WriteLog "iMail","Ошибка при " & Action & ":" & RC
Wsock.Close
Set Wsock=Nothing
ExitIt
Exit Sub
End If
If ACTION="LETTER" Then
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.OpenTextFile(WHERE_WRITE &"\"& CurrentLetter & ".eml" , 8, True)
If Err.Number<>0 Then ExitIt
f.Write RC
If Err.Number<>0 Then ExitIt
f.Close
If Err.Number<>0 Then ExitIt
On Error GoTo 0
If InStr(1, RC, vbLf & "." & vbCrLf) Then
Action=Recieved
End If
Else
Action=RC
End If
STARTT=Now()
End sub
Function wait(what)
STARTT=Now()
Action=what
Do While Action=what
Wscript.Sleep(500)
If Wsock.State=9 Then 'Error
Action="Wsock.State=9"
Exit Do
End If
NOWW=Now()
HOW_MANY = DateDiff("s",STARTT,NOWW)
If HOW_MANY=60 Then
WHAT_KEY=WshShell.Popup("Нет отклика от сервера минуту. Ждать?", 30, "Самозакрывающееся окно", 4 + 32)
If WHAT_KEY=7 Or WHAT_KEY=-1 Then
WriteLog "iMail","Нет отклика от сервера.Выход"
ExitIt
End If
STARTT=Now()
End If
Loop
wait=Action
End Function
Function NUM(what)
For i=1 to Len(what)
If Mid(what,i,1)=" " Then Exit Function
NUM=NUM & Mid(what,i,1)
Next
End Function
Sub ExitIt()
LOG_FILE.Close
On Error Resume Next
Wsock.Close
Set Wsock=Nothing
Wscript.Quit
End Sub
'----------'
'Лог
'
Function WriteLog(TITLE,WHAT)
On Error Resume Next
LOG_FILE.Write TITLE & "[" & Now & "]-" & WHAT & vbCrLf
Wscript.StdOut.Write (vbCrLf & WHAT & vbCrLf)
End Function
'
'Конец Лога
'----------'
Function CreateArxiv(WHERE)
'Если надо, создадим архивный каталог
what=WHERE & "\ARXIV"
CreateIfNotExists what
what=what & "\" & Year(Date)
CreateIfNotExists what
what=what & "\" & Month(Date)
CreateIfNotExists what
what=what & "\" & Day(Date)
CreateIfNotExists what
WriteLOG "","Подготовили архивный каталог..."
CreateArxiv=what
End Function
Function CreateIfNotExists(what)
If Not (fso.FolderExists(what)) Then
On Error Resume Next
fso.CreateFolder(what)
If Err.Number<>0 Then
MsgBox "Не создать " & what
Wscript.Quit
End If
End If
End Function
Автор скрипта — ingvar68.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.