我创建了宏来搜索具有特定主题名称的 Outlook 最新电子邮件，然后通过将 Excel 中的某些范围粘贴到电子邮件正文中来转发它，并且代码对于最近的电子邮件运行良好。但不适用于存档电子邮件。当我搜索旧电子邮件时，我收到“类型不匹配”错误。
这是代码：
Sub Online_Email()
Dim outlookApp As Variant
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olFMail As Outlook.MailItem
Dim myTasks As Variant
Dim sir() As String
Dim rng As Range
Dim wb As Workbook
Dim obwb As Workbook
'Set outlookApp = New Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
For Each wb In Workbooks
If wb.Name Like "Consolidated observation file*.xlsb" Then
Set obwb = wb
obwb.Activate
Exit For
End If
Next
lastrow = obwb.Sheets("Daily Observation").Range("F50000").End(xlUp).Row
Set rng = obwb.Sheets("Daily Observation").Range(Cells(8, 1), Cells(lastrow, 6)).SpecialCells(xlCellTypeVisible)
'
'Set olMail = myTasks.Find("[Subject] = ""123456""")
'
For Each olMail In myTasks
'
If (InStr(1, olMail.Subject, "Consolidated Observations", vbTextCompare) > 0) Then
Set olFMail = olMail.Forward
With olFMail
.To = "[email protected];[email protected];[email protected];[email protected]"
.CC = "[email protected];[email protected]"
.HTMLBody = "<HTML><BODY>" & obwb.Sheets("AutoMail").Range("a1") & "<br><br>" & obwb.Sheets("AutoMail").Range("a2") & "</BODY></HTML>" & RangetoHTML(rng) & olFMail.HTMLBody
.Subject = obwb.Sheets("AutoMail").Range("i3")
End With
Set Myattachments = olFMail.Attachments
While Myattachments.Count > 0
Myattachments.Remove 1
Wend
olFMail.Attachments.Add "\\IPSAABACUS\CM_Shared$\SalesForce\Jyoti Sahay\VA-Training\Scrubbing feedback\Observations\Consolidated observation file - Oct-2022.rar"
olFMail.Display
Exit For
End If
Next
'Dim outForward As Outlook.MailItem
'Set outForward = ActiveExplorer.Selection.Item(1).Forward
'outForward.Recipients.Add "[email protected]"
'outForward.Save
End Sub
Function RangetoHTML(rng As Range)
Dim obj As Object
Dim txtstr As Object
Dim File As String
Dim wb As Workbook
File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set wb = Workbooks.Add(1)
With wb.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
.Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With wb.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=File, _
Sheet:=wb.Sheets(1).Name, _
Source:=wb.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set obj = CreateObject("Scripting.FileSystemObject")
Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
RangetoHTML = txtstr.readall
txtstr.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
wb.Close savechanges:=False
Kill File
Set txtstr = Nothing
Set obj = Nothing
Set wb = Nothing
End Function
首先，您需要记住，Outlook 文件夹可能包含不同类型的项目 - 约会、便笺、邮件等。因此，当您循环代码中的所有项目时，使用对象进行迭代并检查其值是有意义的。使用 MessageClass 属性输入或仅使用以下代码：
If TypeName(Item) = "MailItem" Then
其次，迭代文件夹中的所有项目并不是一个好主意。使用
FindFindNextRestrict