检查新收到的电子邮件是否有附件

Question

我对VBA有点陌生，目前我正在编写一个VBA代码，以检查收到的新邮件是否有附件。如果不是。它将发送电子邮件给发件人，他们发送的电子邮件没有附件。

密码是附加的。

Option Explicit
Sub checkAttachment(Item As Outlook.MailItem)
    Dim outAttachment As Outlook.Attachments
    Dim outerAttachment As Attachment
    Dim OutApp As Object
    Dim OutMail As Object

    If outAttachment = 0 Then
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    'On Error Resume Next

    With OutMail
    'recipient is the sender
    .To = "test@gmail.com"
    'auto-reply should be "RE : Subject of the message
    .Subject = "RE : "
    .CC = ""
    .BCC = ""`enter code here`
    .Body = "No attachment was found"
    .Display
    End With

    End If
    On Error GoTo 0
End Sub

试着调整并且成功了..。现在我的问题是允许文件类型。我只希望jpeg、tiff和pdf被接受，但它只会发送一个信息，即附件是无效的文件类型。

代码是这样的

    Option Explicit
    Public Sub CheckAttachment(Item As Outlook.MailItem)
        Dim olInspector As Outlook.Inspector
        Dim olDocument As Outlook.DocumentItem
        Dim olSelection As Outlook.Selection
        Dim objAtt As Outlook.Attachment
        Dim ft As FileTypes
        Dim olReply As MailItem
        Dim FileExtension As String
        FileExtension = "jpeg, jpg, tiff, pdf"

        '// Check for attachment
        If Item.Attachments.Count > 1 Then
        GoTo CheckFileType1
            End If



    CheckFileType1:
        If Item.Attachments(Item.Attachments, ".tiff") Then
        GoTo CheckFileType2
        End If

    CheckFileType2:
        If Item.Attachments(Item.Attachments, ".jpeg") Then
        GoTo CheckFileType3
        End If

    CheckFileType3:
        If Item.Attachments(Item.Attachments, ".pdf") Then
        GoTo SendMail
        Else
        Exit Sub
        End If

    SendMail:
        Set olReply = Item.Reply '// Reply if no attachment found
        olReply.Body = "No attachment was found. Re-send the email and ensure that the needed file is attached." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "This is a system generated message. No need to reply. Thank you."
        olReply.Send

        Set olInspector = Nothing
        Set olDocument = Nothing
        Set olSelection = Nothing


    End Sub

Answer 1

这应该能行。

Option Explicit
Public Sub CheckAttachment(Item As Outlook.MailItem)
    Dim olInspector As Outlook.Inspector
    Dim olDocument As Word.Document
    Dim olSelection As Word.Selection
    Dim olReply As MailItem

    '// Check for attachment
    If Item.Attachments.Count > 0 Then
        Exit Sub
    Else
        Set olReply = Item.Reply '// Reply if no attachment found
        olReply.Display
    End If

    Set olInspector = Application.ActiveInspector()
    Set olDocument = olInspector.WordEditor
    Set olSelection = olDocument.Application.Selection

    olSelection.InsertBefore "No attachment was found, Thank you."

    '// Send
    olReply.Send

    Set olInspector = Nothing
    Set olDocument = Nothing
    Set olSelection = Nothing
End Sub

Answer 2

设置OutApp = CreateObject("Outlook.Application")

如果代码是从规则运行的，则不需要创建新的Outlook应用程序实例。您可以使用Application属性代替。

检查新收到的电子邮件是否有附件

附件类的MailItem属性返回表示指定项的所有附件的附件对象。计数属性将告诉您附加项的数量。请注意，消息正文中显示的嵌入图像也可以作为附件处理。因此，您需要检查每个附件是否隐藏。您可以为此使用PropertyAccessor对象(参见附件类的相应属性)。您只需要获得PR_ATTACHMENT_HIDDEN属性值，DASL名称就是http://schemas.microsoft.com/mapi/proptag/0x7FFE000B。

 Dim prop As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
 atc.PropertyAccessor.GetProperty(prop)

然后，如果需要，您可以发送一个回复或创建一个新的项目。您需要使用的不是显示方法，而是发送方法。