Пересылка входящих писем Outlook посредством VBA

Private Sub Application_Startup()
'событие запуска аутлука
Dim objApp As Object
On Error Resume Next
   Set objApp = GetObject(, "Excel.Application")
If Err Then
   On Error Resume Next
      Set objApp = CreateObject("Excel.Application")
   If Err Then
      MsgBox "Не удалось запустить Excel"
      Exit Sub
   End If
End If
 
Dim objBook As Object
Set objBook = objApp.WorkBooks.Open(BookName) 'здесь указать имя книги
'здесь вставить код, вычитывающий адресатов из книги
 
Set objApp = Nothing
Set objBook = Nothing
End Sub
 
Private Sub Application_NewMail()
'событие получения нового письма
Dim objMails As Object
Dim objMail As Object
Set objMails = Application.Session.GetDefaultFolder(olFolderInbox).Items
Set objMail = objMail(objMails.Count)
objMail.Forward
objMail.Recipients.Add "<сюда вписать адресата>"
objMail.Send
Set objMails = Nothing
Set objMail = Nothing
End Sub

Private Sub Application_NewMail()
'событие получения нового письма
Dim objMails As Object
Dim objMail As Object
Dim objBook As Object 
Set objApp = Nothing
Set objBook = Nothing
Set objMails = Application.Session.GetDefaultFolder(olFolderInbox).Items
Set objMail = objMail(objMails.Count)
objMail.Forward
Set objBook = objApp.WorkBooks.Open(BookName) 'здесь указать имя книги
'здесь вставить код, вычитывающий адресатов из книги
objMail.Send
Set objMails = Nothing
Set objMail = Nothing
End Sub

Dim countStaff As Long
countStaff =  'здесь определеить и присвоить количество адресатов
ReDim arrayName(countStaff) As String
Dim I As Long
For I = 1 To countStaff
    arrayName(countStaff) = objBook.Sheets("Лист1").Cells(countStaff, 1)
Next

Private Sub Application_Startup()
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, "Excel.Application")
If Err Then
On Error Resume Next
Set objApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Не найден Excel"
Exit Sub
End If
End If
 
Dim objBook As Object
Set objBook = objApp.WorkBooks.Open("C:\Users\HP\Desktop\Êíèãà1.xlsx")
Dim countStaff As Long
countStaff =  'çäåñü îïðåäåëåèòü è ïðèñâîèòü êîëè÷åñòâî àäðåñàòîâ'
ReDim arrayName(countStaff) As String
Dim I As Long
For I = 1 To countStaff
    arrayName(countStaff) = objBook.Sheets("Ëèñò1").Cells(countStaff, 1)
Next
Set objApp = Nothing
Set objBook = Nothing
End Sub
 
Private Sub Application_NewMail()
Dim objMails As Object
Dim objMail As Object
Set objMails = Application.Session.GetDefaultFolder(olFolderInbox).Items
Set objMail = objMails(objMails.Count)
objMail.Forward
objMail.Recipients.Add "<katerina.popkova@list.ru,elenaram@mail.ru>"
objMail.Send
Set objMails = Nothing
Set objMail = Nothing
End Sub

Option Explicit
Dim arrayName() As String
Dim currentStaff As Long
 
Private Sub Application_Startup()
'событие запуска аутлука
Dim objApp As Object
On Error Resume Next
   Set objApp = GetObject(, "Excel.Application")
If Err Then
   On Error Resume Next
      Set objApp = CreateObject("Excel.Application")
   If Err Then
      MsgBox "Не удалось запустить Excel"
      Exit Sub
   End If
End If
 
Dim objBook As Object
Set objBook = objApp.Workbooks.Open("C:\Users\HP\Desktop\Книга1.xlsx")
 
Dim countStaff As Long
With objBook.Sheets("Лист1")
countStaff = .UsedRange.Row
ReDim arrayName(countStaff) As String
 
Dim I As Long
For I = 1 To countStaff
    arrayName(countStaff) = .Cells(countStaff, 1) 'вместо 1 - номер столбца с адресами
Next
End With
 
Set objApp = Nothing
Set objBook = Nothing
 
currentStaff = 1
End Sub
 
Private Sub Application_NewMail()
'событие получения нового письма
Dim objMails As Object
Dim objMail As Object
Set objMails = Application.Session.GetDefaultFolder(olFolderInbox).Items
Set objMail = objMails(objMails.Count)
objMail.Forward
objMail.Recipients.Add arrayName(currentStaff)
objMail.Send
Set objMails = Nothing
Set objMail = Nothing
 
If currentStaff < UBound(arrayName) Then
   currentStaff = currentStaff + 1
Else
   currentStaff = 1
End If
End Sub

With objBook.Sheets("Лист1")
countStaff = .UsedRange.Rows.Count
ReDim arrayName(countStaff) As String
For I = 1 To countStaff
    arrayName(I) = .Cells(I, 1) 'вместо 1 - номер столбца с адресами
Next
End With