VBA не пойму почему не скрипт читает второе сообщение

[Drek]

Вот код

Sub Application_NewMail()

Dim income(1000) As String
Dim FolderName As String
Dim Myf(50) As String
Dim data As Date
Dim MonNum As String
Dim oOutlook As New Outlook.Application
Dim oMessage As Outlook.MailItem
Dim oInbox As MAPIFolder
Dim oItem As MailItem

Set myOlApp = CreateObject("Outlook.Application")
Set oMessage = oOutlook.CreateItem(olMailItem)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast

msg = 1
i = 0
slovo = "Ïðèâåò"
papka1 = "c:\New\"
papka2 = "C:\New\old\"

message = "Âõîäå îáðàáîòêè áûëè äîïóùåíû îøèáêè:" & Chr(13)
atcount = myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).Attachments.Count
subj = myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).Subject
Send = myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).SenderEmailAddress

If subj = "Test" Then

  If atcount <> 1 Then
  
    message = message & "- Íåò âëîæåííûõ ôàéëîâ èëè ôàéëîâ áîëüøå ÷åì îäèí!" & Chr(13)
    i = i + 1
    
  Else

    If myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).Attachments(1) Like "*.rar" Then
    
      MessageName = Send & subj & myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).Attachments(1)
      n = 0
      
      Do While Dir(pathOL & MessageName) <> ""
        n = n + 1
        MessageName = n & Send & subj & myNameSpace.GetDefaultFolder(olFolderInbox).Items(1).Attachments(1)
      Loop
      
      myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1).SaveAsFile papka1 & MessageName
      myName = Dir(papka1, vbNormal)
      
      Do While myName <> ""
        WinRarApp = "C:\Program Files\WinRAR\WinRAR.exe e -o+"
        adr = WinRarApp & " """ & ipath & myName & """ """ & papka1 & """ "
        RetVal = Shell(adr, vbHide)
        fle = papka1 & myName
        myName = Dir()
      Loop
      
      Dim o As Date
        o = Now
      Do
      Loop While DateDiff("s", o, Now) < 10
      
      Kill fle
      myName = Dir(papka1, vbNormal)
      
      Do While myName <> ""
      
        On Error Resume Next
        x = GetObject(papka1 & myName).Worksheets(1).Rows(1).Find(slovo).Column
        GetObject(papka1 & myName).Close False
        
        If Err = 0 Then
        
          message = message & "- Íå óäàëîñü íàéòè ôàéë xls èëè xlsx èëè â í¸ì íå íàéäåíà èñêîìàÿ ñòðîêà!" & Chr(13)
          i = i + 1
          
        Else
        
          Name ipath & myName As papka2 & myName
          Kill papka1 & myName
          myName = Dir()
        End If
      Loop
    Else
    
      message = message & "- Ôàéë íå ÿâëÿåòüñÿ ôàéëîì  rar!" & Chr(13)
      i = i + 1
        
    End If
  End If
End If
myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = False
If i > 0 Then
  oMessage.To = Send
  oMessage.Subject = "Ñîîáùåíèå îá îøèáêå"
  oMessage.Body = message
  oMessage.Send
End If


End Sub

Этот скрипт автоматически обрабатывает входящие сообщение в outlooke.
Но вот в чём загвоздка
Когда папка пуста и приходит сообщение он не работает. (Не знаю почему)
Кода в папке уже есть сообщение и приходит ещё одно, он работает.(Так и должно быть)
Когда в папке нет сообщений и приходит больше двух сообщений он работает. (Тоже нормально)
Как сделать что бы он всегда работал.
Помогите пожалуйста.
Извините за ошибку в название темы