Сбой Outlook при чтении почты с помощью Excel VBA - PullRequest
Новая
       68

Сбой Outlook при чтении почты с помощью Excel VBA

0 голосов
/ 27 сентября 2019

У меня есть этот макрос в Excel, который проверяет мой почтовый ящик outlook каждые 30 секунд, и если получено новое письмо, отправьте тело в Whatsapp: 

Sub holaa()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim html As Object: Set html = CreateObject("htmlfile")
Dim filas As Object
Dim objNSpace As Object
Set objNSpace = objOutlook.GetNamespace("MAPI")
Dim myFolder As Object
Set myFolder = objNSpace.Folders("myemail").Folders("somefolder")
Dim Item As Object
Dim objMail As Outlook.MailItem
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
For Each objitem In myFolder.Items
    If objitem.Class = olMail Then
        Set objMail = objitem
        If objitem.UnRead = True Then
            html.body.innerHTML = objMail.HTMLBody
            Sheets("Hoja1").Range("A" & Sheets("Hoja1").Range("A1").CurrentRegion.Rows.Count + 1) = objMail.Subject
            Sheets("Hoja1").Range("B" & Sheets("Hoja1").Range("A1").CurrentRegion.Rows.Count) = objMail.body
            Sheets("Hoja1").Range("C" & Sheets("Hoja1").Range("A1").CurrentRegion.Rows.Count) = objMail.ReceivedTime
            objitem.UnRead = False
        End If
    End If
Next

'Send body of new mail to Whastapp 
Shell ("C:\Program Files (x86)\Google\Chrome\Application\Chrome.exe -url https://web.whatsapp.com/")
Application.Wait (Now + TimeValue("0:00:06"))
SendKeys "{TAB}", True
SendKeys "AnyContact", True
Application.Wait (Now + TimeValue("0:00:05"))
SendKeys "{TAB}", True
 Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{TAB}", True
 Application.Wait (Now + TimeValue("0:00:02"))
SendKeys "{TAB}", True
 Application.Wait (Now + TimeValue("0:00:02"))
SendKeys Sheets("Hoja1").Range("B" & Sheets("Hoja1").Range("A1").CurrentRegion.Rows.Count) & " + {ENTER}", True
Application.Wait (Now + TimeValue("0:00:10"))
SendKeys "^w", True

objOutlook.Quit
Set objMail = Nothing
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing

Application.Wait (Now + TimeValue("0:00:5"))

Application.OnTime Now + TimeValue("00:00:30"), "holaa", Schedule = True
Sheets("Hoja2").Range("A" &         
Sheets("Hoja2").Range("A1").CurrentRegion.Rows.Count + 1) = Now
End Sub

Этот макрос работает потрясающе в течение 3 или 4 часов, пока яполучить сообщение об ошибке: «Outlook исчерпал все общие ресурсы, закройте все приложения обмена сообщениями и перезапустите Outlook (например, Skype для бизнеса)», после этого мне нужно сбросить Outlook, если я хочу продолжить

Outlook has exhausted all shared resources, please close all messaging applications and restart Outlook (example: Skype for Business)

Любые идеи, как я могу преодолеть эту проблему, чтобы мой макрос мог работать в течение нескольких дней?

...