excel - 使用 Excel VBA 阅读邮件时 Outlook 崩溃

Question

我在 excel 上有这个宏，它每 30 秒检查一次我的 Outlook 邮箱，如果收到新邮件，请将正文发送到 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 for Business）”之后，如果我想继续，我必须重置 Outlook

有什么想法可以解决这个问题，以便我的宏可以运行几天吗？

标签： excelvbaoutlookwhatsapp