Question

我最近一直收到这个错误，我不知道缺少什么？它曾经工作过。调试器在myStr = objItem.htmlbody处停止并发出运行时错误430（类不支持自动化或不支持预期的接口）

Sub UpdateAllMessages()
' Remove the appended url from all effected urls
' Start execution here
Dim olkSto As Outlook.Store
For Each olkSto In Session.Stores
    ProcessFolder olkSto.GetRootFolder()
Next
MsgBox "All hyperlinks are back to their original state.", vbInformation, "Success"
End Sub

Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim objItem As Object, olkSub As Outlook.MAPIFolder
    Dim objMail As MailItem

Dim myStr As String

'Process each message
For Each objItem In olkFld.Items
    'Only  messages, not receipts or appointment requests, etc.
    If objItem.Class = olMail Then
        ' Store the HTML Bodyin a variable
        myStr = objItem.htmlbody <<<<<<<<<<<<<<<<<<<<<<< DEBUG STOPS HERE ERROR
        ' Update all URLs
        myStr = Replace(myStr, "https://test.com/apps/verify/?url=", "", , , vbTextCompare)
        ' only if there is a change
        ' Assign back to HTML Body
        If Len(myStr) <> Len(objItem.htmlbody) Then
            objItem.htmlbody = myStr
            ' Save the mail
            objItem.Save
        End If
    End If
Next
Set olkMsg = Nothing
For Each olkSub In olkFld.Folders
    ProcessFolder olkSub
Next
Set olkSub = Nothing

End Sub

Answer 1

我对我不喜欢的文件夹的粗略解决方案是一个简单的Select Case：

Select Case olkFld.Name
  Case "RSS Feeds", "Journal", "Search Folders", "Draft"
    ' Ignore
  Case Else
    ' Process folder that might contain something interesting
    : :
    : :
End Select

替代建议

您的代码在我的系统上没有错误，因此我无法测试此代码，但它可能有所帮助。以下命令关闭问题陈述的标准错误处理程序。

Dim ErrNum As Long
Err.Clear
On Error Resume Next
myStr = objItem.HTMLBody   '<<<<<<<<<<<<<<<<<<<<<<< DEBUG STOPS HERE ERROR
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
  ' Update all URLs
  myStr = Replace(myStr, "https://test.com/apps/verify/?url=", "", , , vbTextCompare)
  ' only if there is a change
  ' Assign back to HTML Body
  If Len(myStr) <> Len(objItem.HTMLBody) Then
      objItem.HTMLBody = myStr
      ' Save the mail
      objItem.Save
  End If
End If

更新收件箱中的所有邮件以删除某些文本运行时错误430 VBS

1 个答案: