Question

我有一套现有的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

Answer 1

我认为这就是你要找的东西。

 Set MailItem.Attachments = objMail.Attachments

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

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

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

1 个答案: