Question

我想创建一个自动邮件，它将回复Outlook中位于PST文件中的电子邮件，该文件在Excel中具有相同的主题。

以下是我的excel文件。我想搜索具有相同服务标签的电子邮件@ Column D

使用自定义HTML正文回复我的问题现在我无法显示我想要的电子邮件并回复它。

希望你们都能帮助我。

这是我尝试的代码。

Sub AutoMail()

'Find OOW_Request
    Dim OOW As Workbook
    Dim s As Workbook

    For Each s In Workbooks
    If Left(s.Name, 11) = "OOW Request" Then
        Set OOW = Workbooks(s.Name)
    End If
Next s

    Dim rng As Range
    Dim rngTilte As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lRow As Integer
    Dim i As Integer
    Dim toDate As Date
    Dim toList As String
    Dim eSubject As String
    Dim eBody As String
    Dim eBodyLast As String

    Dim olNs As Outlook.Namespace

    Dim olMail As Outlook.MailItem
    Dim olReply As Object ' Reply
    Dim olRecip As Recipient ' Add Recipient

    OOW.Sheets("OOW_REQUEST").Select
    lRow = OOW.Sheets("OOW_REQUEST").Range("D" & Rows.Count).End(xlUp).Row

For i = 2 To lRow
If OOW.Sheets("OOW_REQUEST").Range("L" & i) = "" Then

    Set rng = Nothing
    Set rngTilte = Nothing
    On Error Resume Next
    Set rngTilte = OOW.Sheets("OOW_REQUEST").Range("D1:M1").SpecialCells(xlCellTypeVisible)
    Set rng = OOW.Sheets("OOW_REQUEST").Range("D" & i & ":" & "M" & i). _
    SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set olNs = OutApp.GetNamespace("MAPI")
    olNs.AddStore ("C:\Users\Ruzaini_Subri\Documents\Outlook Files\OOW.pst")
    Set myTasks = olNs.Session.Folders.Item(2).items

For Each olMail In myTasks

     If (InStr(1, olMail.Subject, "Cells(i, 4)", vbTextCompare) > 0) Then

'    toList = Cells(i, 8)
'   eSubject = "yOOW part requestz|| Part: " & Cells(i, 5) & "  || TAG: " & Cells(i, 4)
    eBody = "<BODY style=font-size:10pt;font-family:Arial><p>Hi " & Cells(i, 8) & "</p>" & _
            "Please advise if you can support this OOW request by replying this email." & "<br><br></BODY>"
    eBodyLast = "<BODY style=font-size:9pt;font-family:Arial><br><br>" & "<p>Thank You.</p>" & _
                "<strong>---------------------------------------------------------------------</strong><br>" & _
                "<span style=""color: #333399;""><strong>Ruzaini Subri</strong></span></BODY>"

    On Error Resume Next
    Set olReply = olMail.ReplyAll
    Set olRecip = olReply.Recipients.Add("& Cells(i, 8) &") ' Recipient Address
        olRecip.Type = olTo
            olReply.HTMLBody = eBody & RangetoHTML(rngTilte) & RangetoHTML(rng) & eBodyLast & vbCrLf & olReply.HTMLBody
        olReply.Display
        'olReply.Send
    On Error GoTo 0

    End If
    Next olMail

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set olMail = Nothing
    Set OutApp = Nothing
    Cells(i, 12) = "TBU"
End If
Next i

End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]>&nbsp;&nbsp;<![endif]-->", "")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

我在互联网搜索后解决了这个问题您可以在Excel中映射Outlook文件夹ID，并将其引用以查找所需的电子邮件。

在Outlook中查找文件夹ID

Sub Test()

Dim app As Outlook.Application
Dim nms As Outlook.Namespace
Dim fld As Outlook.Folder

Set app = GetObject(, "Outlook.Application")

Set nms = app.GetNamespace("MAPI")

Set fld = nms.PickFolder

Debug.Print "StoreID: " & fld.StoreID
Debug.Print "EntryID: " & fld.EntryID

Sheets("MACRO").Range("N10") = fld.StoreID
Sheets("MACRO").Range("N11") = fld.EntryID

Call MessageBoxTimer

End Sub

在代码中使用

    Dim StoreID As Variant
    Dim EntryID As Variant

    StoreID = ws.Range("N1").Value
    EntryID = ws.Range("N2").Value

For i = 2 To lRow
    If OOW.Sheets("WORKING FILE").Range("W" & i) = "YES" And _
    OOW.Sheets("WORKING FILE").Range("B" & i) = "Ruz" And _
    OOW.Sheets("WORKING FILE").Range("Y" & i) = "" Then

    Set rng = Nothing
    Set rngTilte = Nothing
    On Error Resume Next
    Set rngTilte = OOW.Sheets("WORKING FILE").Range("D1:X1").SpecialCells(xlCellTypeVisible)
    Set rng = OOW.Sheets("WORKING FILE").Range("D" & i & ":" & "X" & i). _
    SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set olNs = OutApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetFolderFromID(EntryID, StoreID)
    Set myTasks = Fldr.items

在PST Outlook中回复具有相同值的电子邮件中的电子邮件[相同值为服务标签]

1 个答案: