Поиск письма из Excel в OutLook по ID, Скрипт который ищет письмо по ENTRY.ID, которое хранится в Excel и пересылает его адресату который обозначен в той же строке
Пробовал написать скрипт в Excel, который берет ENTRY.ID из строки которая уже его содержит и имя получателя и ему пресылает письмо письмо. Не получилось т.к. видимо не силен в конструкциях языка. Сейчас упростил до задачи: поиск письма содержащего определенный ID. Не работает: Run-time error Type mismatch Помогите найти ошибку:
Код
Sub Looking_for_the_ID()
Dim i As Integer ' Счетчик
Dim sSID As String
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("mail-order")
myRecipient.Resolve
Set mofolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Dim msg As Outlook.MailItem
sSID ="0000000001F98937A4C1BD4E897050339DC29D150700A652F366EFD5944EB11E2F3EB811D605004D9A94DB530000A652F366EFD5944EB11E2F3EB811D605009ACFA60A430000"
MsgBox sSID
If mofolder.Items.Count > 0 Then
MsgBox "Папка не пустая"
End If
i = mofolder.Items.Count
MsgBox i, , "Всего писем"
For Each msg In mofolder.Items
If msg.EntryID = sSID Then
GoTo Reply
End If
i = i - 1
Next
GoTo Finita
Reply:
MsgBox "Отправка письма"
MsgBox i
Finita:
MsgBox "Письмо не было найдено"
End Sub
Sub Looking_for_the_ID()
Dim i As Integer ' Счетчик для цикла перебора писем
Dim sTo As String
Set myOlApp = CreateObject("Outlook.Application") ' Присвоить [myOlApp] приложение Outlook
Set myNamespace = myOlApp.GetNamespace("MAPI") ' Присвоить [myNamespace] модель [MAPI]
Set myRecipient = myNamespace.CreateRecipient("mail-order") ' Присвоить [myRecipient] (Получатель писем) ["mail-order"]
myRecipient.Resolve
Set mofolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox) ' Присвоить [mofolder] папку [Inbox] ящика ["mail-order"]
Dim msg As Outlook.MailItem ' Присвоить [msg] тип - объект [Outlook.MailItem]
sSID = "0000000001F98937A4C1BD4E897050339DC29D150700A652F366EFD5944EB11E2F3EB811D605004D9A94DB530000A652F366EFD5944EB11E2F3EB811D605009B073E897D0000" ' Присвоить [sSID] Значение ID письма для последующего поиска
MsgBox sSID
If mofolder.Items.Count > 0 Then ' Проверка того что в папке [myRecipient] есть письма
MsgBox "Папка найдена"
End If
'MsgBox mofolder.Items.Count
i = mofolder.Items.Count ' Присвоить переменной [i] количество писем в В папке [mofolder], Входящие mail-order
'MsgBox i, , "Всего писем"
For i = mofolder.Items.Count To 1 Step -1 ' Цикл перебора писем от последнего к первому
'MsgBox mofolder.Items(i).EntryID
If sSID = mofolder.Items(i).EntryID Then ' Проверка соотвествия искомого ID текущему в цикле перебора писем
'MsgBox "Письмо найдено"
GoTo Reply ' Переход на метку [Reply]
End If
Next i
GoTo Finita ' Переход в конец скрипта при неудачном поиске
' Метка
Reply:
MsgBox "Произошел преход в пункт Отправка письма"
'MsgBox "Переход в SendMail"
' Модуль отправки письма НАЧАЛО
With mofolder.Items(i).Reply 'objMail Переслать найденное письмо
.To = sTo 'адрес получателя
' '.CC = sHead 'адрес для копии
' '.BCC = "" 'адрес для скрытой копии
' .Subject = sSubject 'тема сообщения
' .Body = sBody 'текст сообщения
' '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
' '.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
' .SentOnBehalfOfName = "order@aircool.ru"
.Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра (.Send)
' '.SendUsingAccount = objOutlookApp.Session.Accounts.Item(1)
' '.From = "order@aircool.ru"
' '.Send
End With
' 'Модуль отправки письма КОНЕЦ
GoTo Finita
NotFound:
MsgBox "Письмо не было найдено, Найдите самостоятельно!"
Finita:
MsgBox "Finita"
End Sub