Question

我对Excel中的VBA很有经验，但在Outlook中却很新。有没有人知道在签名下列出传出电子邮件中附件的脚本？要由功能区项目或键盘快捷键触发吗？

我经常发送带有附件的电子邮件，并希望通过查看对话中的任何电子邮件来了解我发送的内容，而不是必须找到包含附件的电子邮件。

希望此图片能够澄清：

我想生成该电子邮件的最后一行。我有一个脚本在回复到电子邮件时提取此信息*但我不知道如何从我即将发送的电子邮件中获取附件信息。

*此处可用：http://www.slipstick.com/developer/code-samples/insert-attachment-names-replying/

Answer 1

您可能需要进行一些调整，但您可以使用一些现有代码并将其放入ItemSend事件过程中：

每当您发送电子邮件时，这都会自动列出附件。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim oAtt As Attachment
Dim strAtt As String
Dim olInspector As Inspector
Dim olDocument As Object
Dim olSelection As Object

    For Each oAtt In Item.Attachments

        strAtt = strAtt & "<<" & oAtt.filename & ">> "

    Next


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

    olSelection.InsertBefore strAtt


End Sub

当然可以使用功能区自定义来执行此操作，即劫持现有的上下文菜单，以便您可以选择右键单击＆amp;显示附件名称，但坦率地说，功能区UI开发是相当先进的技术，并且可能因这种特定需求而过度使用。

Answer 2

这是我的解决方案。在＆＃34;发送＆＃34;它会检测所需的附件名称，然后在签名后立即附加它们。如果存在现有的附件列表，则会覆盖它。

我已经使用with函数来封装单独的部分 - ＆＃34;＆＃39;检查附件信息是否已被添加＆＃34;部分是可选的。要在标准模块中使用它，只需用sub() AttachmentLister

替换第二行

'This sub inserts the name of any meaningful attachments just after the signature
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim oAtt As Attachment
Dim strAtt, DateMark, ShortTime, FinalMsg, AttachName As String
Dim olInspector, oInspector As Inspector
Dim olDocument As Object
Dim olSelection As Object
Dim NewMail As MailItem
Dim AttchCount, i As Integer

Set oInspector = Application.ActiveInspector
Set NewMail = oInspector.CurrentItem

With NewMail
    AttchCount = .Attachments.Count

    If AttchCount > 0 Then
        For i = 1 To AttchCount
        AttachName = .Attachments.Item(i).DisplayName
            If InStr(AttachName, "pdf") <> 0 Or InStr(AttachName, "xls") <> 0 Or InStr(AttachName, "doc") <> 0 Then
                strAtt = strAtt & "<<" & AttachName & ">> " & vbNewLine
            End If
        Next i
    End If
End With

GoTo skipsect ' this section is an alternative method of getting attachment names
        For Each oAtt In Item.Attachments
            If InStr(oAtt.FileName, "xls") <> 0 Or InStr(oAtt.FileName, "doc") <> 0 Or InStr(oAtt.FileName, "pdf") <> 0 Or InStr(oAtt.FileName, "ppt") <> 0 Or InStr(oAtt.FileName, "msg") <> 0 Or oAtt.Size > 95200 Then
            strAtt = strAtt & "<<" & oAtt.FileName & ">> " & vbNewLine
        End If
        Next
        Set olInspector = Application.ActiveInspector()
        Set olDocument = olInspector.WordEditor
        Set olSelection = olDocument.Application.Selection
skipsect:


'ShortTime = Format(Time, "Hh") & ":" & Format(Time, "Nn") & " "
DateMark = " (dated " & Date & ShortTime & ")"
If strAtt = "" Then
FinalMsg = ""
Else
FinalMsg = "Documents attached to this email" & DateMark & ": " & vbNewLine & strAtt
End If

Dim inputArea, SearchTerm As String
Dim SignatureLine, EndOfEmail As Integer

'Find the end of the signature
With ActiveInspector.WordEditor.Application
    .Selection.WholeStory
    .Selection.Find.ClearFormatting
    With .Selection.Find
        .Text = "Sales Co-ordinator"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
    End With
    .Selection.Find.Execute
    SignatureLine = .Selection.Range.Information(wdFirstCharacterLineNumber) + 1
    .Selection.EndKey Unit:=wdLine
End With

'check to see if attachment info has already been added
With ActiveInspector.WordEditor.Application
    .Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
    inputArea = .Selection
    .Selection.MoveUp Unit:=wdLine, Count:=4, Extend:=wdExtend

    'detect existing attachment lists
    If Not InStr(inputArea, "Documents attached to this email") <> 0 Then
        .Selection.TypeParagraph
        .Selection.TypeParagraph
    Else
        With .Selection.Find
            .Text = "From:"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindAsk
            .Format = False
            .MatchCase = True
            .Execute
        End With


    'In case the email being replied to is not in english,
    'try to detect the first line of the next email by looking for mailto
        If .Selection.Find.Found = False Then
            With .Selection.Find
                .Text = "mailto"
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindAsk
                .Format = False
                .Execute
            End With
        End If

        'designate the last line of the email and delete anything between this and the signature
        EndOfEmail = .Selection.Range.Information(wdFirstCharacterLineNumber) - 1
        .Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdMove
        .Selection.MoveUp Unit:=wdLine, Count:=EndOfEmail - SignatureLine, Extend:=wdExtend
        .Selection.Expand wdLine
        .Selection.Delete
    End If
End With

'Insert the text and format it.
With ActiveInspector.WordEditor.Application
    .Selection.TypeParagraph
    .Selection.InsertAfter FinalMsg 'insert the message at the cursor.
    .Selection.Font.Name = "Calibri"
    .Selection.Font.Size = 9
    .Selection.Font.Color = wdColorBlack
End With
lastline:
End Sub

列出签名下的Outlook电子邮件中的附件

2 个答案: