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