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

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

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

希望这幅图能澄清：

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

---

*此处提供：

您可能需要进行一些调整，但您可以使用一些现有代码，只需将其放入

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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
作为附件的Dim oAtt
朦胧如弦
检查员
作为对象的文档
将选定对象作为对象
对于项目中的每个oAtt。附件
strAtt=strAtt&“
下一个
设置olInspector=Application.ActiveInspector（）
Set olDocument=olInspector.WordEditor
设置olSelection=olDocument.Application.Selection
olSelection.InsertBefore strAtt
端接头

---

当然，可以使用功能区自定义来实现这一点，即劫持现有的上下文菜单，这样您就可以选择右键单击并显示附件名称，但坦率地说，功能区UI开发是一项相当先进的技术，对于这一特定需求来说，这可能有些过头了。

您可能需要进行一些调整，但您可以使用一些现有代码，只需将其放入

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

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
作为附件的Dim oAtt
朦胧如弦
检查员
作为对象的文档
将选定对象作为对象
对于项目中的每个oAtt。附件
strAtt=strAtt&“
下一个
设置olInspector=Application.ActiveInspector（）
Set olDocument=olInspector.WordEditor
设置olSelection=olDocument.Application.Selection
olSelection.InsertBefore strAtt
端接头

当然，可以使用功能区自定义来实现这一点，即劫持现有的上下文菜单，这样您就可以选择右键单击并显示附件名称，但坦率地说，功能区UI开发是一项相当先进的技术，对于这一特定需求来说，它可能是一种过度的技术。

这是我的解决方案。在“发送”时，它会检测到所需的附件名称，然后在签名后添加它们。如果存在现有的附件列表，则会覆盖该列表

我使用with函数封装了单独的部分-“检查附件信息是否已经添加”部分是可选的。要在标准模块中使用它，只需将第二行替换为

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

”此子项在签名后插入任何有意义附件的名称
私有子应用程序_ItemSend（ByVal项作为对象，取消作为布尔值）
作为附件的Dim oAtt
Dim strAtt，DateMark，ShortTime，FinalMsg，作为字符串的附件名称
检查员，作为检查员的检查员
作为对象的文档
将选定对象作为对象
将新邮件设置为邮件项
Dim AttchCount，i为整数
设置oInspector=Application.ActiveInspector
设置NewMail=oInspector.CurrentItem
与NewMail
AttchCount=.Attachments.Count
如果ATTCHCUNT>0，则
对于i=1至ATTCHCUNT
AttachName=.Attachments.Item（i）.DisplayName
如果InStr（AttachName，“pdf”）0或InStr（AttachName，“xls”）0或InStr（AttachName，“doc”）0，则
strAtt=strAtt&&&vbNewLine
如果结束
接下来我
如果结束
以
GoTo skipsect'此部分是获取附件名称的另一种方法
对于项目中的每个oAtt。附件
如果InStr（oAtt.FileName，“xls”）0或InStr（oAtt.FileName，“doc”）0或InStr（oAtt.FileName，“pdf”）0或InStr（oAtt.FileName，“ppt”）0或InStr（oAtt.FileName，“msg”）0或oAtt.Size>95200，则
strAtt=strAtt&&&vbNewLine
如果结束
下一个
设置olInspector=Application.ActiveInspector（）
Set olDocument=olInspector.WordEditor
设置olSelection=olDocument.Application.Selection
skipsect：
'短时=格式（时间，“Hh”）和：“&格式（时间，“Nn”）和”
DateMark=“（日期“&日期&短时间-”）
如果strAtt=”“，则
FinalMsg=“”
其他的
FinalMsg=“此电子邮件的附件”&DateMark&“：”&vbNewLine&strAtt
如果结束
Dim inputArea，SearchTerm作为字符串
Dim SignatureLine，EndOfEmail为整数
'查找签名的结尾
使用ActiveInspector.WordEditor.Application
.选择
.Selection.Find.ClearFormatting
With.Selection.Find
.Text=“销售协调员”
.Replacement.Text=“”
.Forward=True
.Wrap=wdFindAsk
.Format=False
.MatchCase=False
以
.Selection.Find.Execute
SignatureLine=.Selection.Range.Information（wdFirstCharacterLineNumber）+1
.Selection.EndKey单位：=wdLine
以
'检查是否已添加附件信息
使用ActiveInspector.WordEditor.Application
.Selection.MoveDown单位：=wdLine，计数：=4，扩展：=wdExtend
inputArea=.Selection
.Selection.MoveUp单位：=wdLine，计数：=4，扩展：=wdExtend
'检测现有附件列表
如果不是InStr（inputArea，“本电子邮件附件”）0，则
.选择.类型段落
.选择.类型段落
其他的
With.Selection.Find
.Text=“From：”
.Replacement.Text=“”
.