vba 转发 Outlook 电子邮件附件的最佳 VB 方法是什么？

What is the best VB method to forward outlook emails attachments?

提问by pivotal developer

I have an existing set of outlook vb codes that help me to forward emails but they do help to forward along with any attachments. any ideas how to include these attachments?

我有一组现有的 Outlook vb 代码，可以帮助我转发电子邮件，但它们确实有助于转发任何附件。任何想法如何包含这些附件？

    Private Const FORWARD_TO_EMAIL As String = "your_email@your_domain.com " 

    Private Const START_MESSAGE_HEADER As String = "--------StartMessageHeader--------" 
    Private Const END_MESSAGE_HEADER As String = "--------EndMessageHeader--------" 
    Private Const FROM_MESSAGE_HEADER As String = "From: " 

    Private Const DESKTOP_SWITCHDESKTOP As Long = &H100 
    Private Declare Sub LockWorkStation Lib "User32.dll" () 
    Private Declare Function SwitchDesktop Lib "user32" (ByVal hDesktop As Long) As Long 
    Private Declare Function OpenDesktop Lib "user32" Alias "OpenDesktopA" _ 
    (ByVal lpszDesktop As Any, _ 
    ByVal dwFlags As Long, _ 
    ByVal fInherit As Long, _ 
    ByVal dwDesiredAccess As Long) As Long 

  Sub ForwardEmail(MyMail As MailItem) 
    On Error Goto EndSub 

    Dim strBody As String 
    Dim objMail As Outlook.MailItem 
    Dim MailItem As Outlook.MailItem 

    Set objMail = Application.Session.GetItemFromID(MyMail.EntryID) 

     ' Initialize email to send
    Set MailItem = Application.CreateItem(olMailItem) 
    MailItem.Subject = objMail.Subject 

    If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then 
         ' Only forward emails when the workstation is locked
        If (Not IsWorkstationLocked()) Then 
            Return 
        End If 

         ' Compose email and send it to your other email
        strBody = START_MESSAGE_HEADER + Chr$(13) + _ 
        FROM_MESSAGE_HEADER + objMail.SenderEmailAddress + Chr$(13) + _ 
        "Name: " + objMail.SenderName + Chr$(13) + _ 
        "To: " + objMail.To + Chr$(13) + _ 
        "CC: " + objMail.CC + Chr$(13) + _ 
        END_MESSAGE_HEADER + Chr$(13) + Chr$(13) + _ 
        objMail.body 
        MailItem.Recipients.Add (FORWARD_TO_EMAIL) 

         ' Do not keep email sent to your mobile account
        MailItem.DeleteAfterSubmit = True 
    Else 
         ' Parse the original mesage and reply to the sender
        strBody = objMail.body 
        Dim posStartHeader As Integer 
        posStartHeader = InStr(strBody, START_MESSAGE_HEADER) 
        Dim posEndHeader As Integer 
        posEndHeader = InStr(strBody, END_MESSAGE_HEADER) 

         'Remove the message header from the body
        strBody = Mid(strBody, 1, posStartHeader - 1) + _ 
        Mid(strBody, posEndHeader + Len(END_MESSAGE_HEADER) + 4) 

        Dim originalEmailFrom As String 
        originalEmailFrom = GetOriginalFromEmail(posStartHeader, _ 
        posEndHeader, objMail.body) 
        If (originalEmailFrom = "") Then 
            Return 
        End If 

        MailItem.Recipients.Add (originalEmailFrom) 

         ' Delete email received from your mobile account
        objMail.Delete 
    End If 

     ' Send email
    MailItem.body = strBody 
    MailItem.Send 


     ' Set variables to null to prevent memory leaks
    Set MailItem = Nothing 
    Set Recipient = Nothing 
    Set objMail = Nothing 
    Exit Sub 

EndSub: 
End Sub 


Private Function GetOriginalFromEmail(posStartHeader As Integer, _ 
    posEndHeader As Integer, strBody As String) As String 
    GetOriginalFromEmail = "" 
    If (posStartHeader < posEndHeader And posStartHeader > 0) Then 
        posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1 
        Dim posFrom As Integer 
        posFrom = InStr(posStartHeader, strBody, FROM_MESSAGE_HEADER) 
        If (posFrom < posStartHeader) Then 
            Return 
        End If 
        posFrom = posFrom + Len(FROM_MESSAGE_HEADER) 
        Dim posReturn As Integer 
        posReturn = InStr(posFrom, strBody, Chr$(13)) 
        If (posReturn > posFrom) Then 
            GetOriginalFromEmail = _ 
            Mid(strBody, posFrom, posReturn - posFrom) 
        End If 
    End If 
End Function 

Private Function IsWorkstationLocked() As Boolean 
    IsWorkstationLocked = False 
    On Error Goto EndFunction 

    Dim p_lngHwnd As Long 
    Dim p_lngRtn As Long 
    Dim p_lngErr As Long 

    p_lngHwnd = OpenDesktop(lpszDesktop:="Default", _ 
    dwFlags:=0, _ 
    fInherit:=False, _ 
    dwDesiredAccess:=DESKTOP_SWITCHDESKTOP) 

    If p_lngHwnd <> 0 Then 
        p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd) 
        p_lngErr = Err.LastDllError 

        If p_lngRtn = 0 Then 
            If p_lngErr = 0 Then 
                IsWorkstationLocked = True 
            End If 
        End If 
    End If 
EndFunction: 
End Function

回答by JohnFx

I think this is what you are looking for.

我想这就是你要找的。

 Set MailItem.Attachments = objMail.Attachments

Or better yet, why rebuild the whole mail object at all:

或者更好的是，为什么要重建整个邮件对象：

 Set MailItem = objMail.Forward()
 MailItem.Recipients.Add(FORWARD_TO_EMAIL)
 MailItem.Send()