使用VBA将发件人电子邮件附加到Outlook中附件的前面

我下载了一个VBA脚本，可以在Outlook中用来保存电子邮件附件

如何编辑此代码，以便在运行脚本时将发件人的电子邮件地址附加到附件名称的前面

Option Explicit

' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr

    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
    ' The window handle of Outlook.
    Private lHwnd As Long

    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If

' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260

' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderPath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.

    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)

        If lHwnd <> 0 Then

            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
                       Err.Description & ".", vbCritical, "Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If

            If objFolder Is Nothing Then
                strFolderPath = ""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                strFolderPath = CGPath(objFolder.Self.Path)

                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    lCountEachItem = objItem.Attachments.Count

                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments

                        ' /* Go through each attachment in the current item. */
                        For Each atmt In atmts

                            ' Get the full name of the current attachment.
                            strAtmtFullName = atmt.FileName

                            ' Find the dot postion in atmtFullName.
                            intDotPosition = InStrRev(strAtmtFullName, ".")

                            ' Get the name.
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                            ' Get the file extension.
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                            ' Get the full saving path of the current attachment.
                            strAtmtPath = strFolderPath & atmt.FileName

                            ' /* If the length of the saving path is not larger than 260 characters.*/
                            If Len(strAtmtPath) <= MAX_PATH Then
                                ' True: This attachment can be saved.
                                blnIsSave = True

                                ' /* Loop until getting the file name which does not exist in the folder. */
                                Do While objFSO.FileExists(strAtmtPath)
                                    strAtmtNameTemp = strAtmtName(0) & _
                                                      Format(Now, "_mmddhhmmss") & _
                                                      Format(Timer * 1000 Mod 1000, "000")
                                    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

                                    ' /* If the length of the saving path is over 260 characters.*/
                                    If Len(strAtmtPath) > MAX_PATH Then
                                        lCountEachItem = lCountEachItem - 1
                                        ' False: This attachment cannot be saved.
                                        blnIsSave = False
                                        Exit Do
                                    End If
                                Loop

                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then atmt.SaveAsFile strAtmtPath
                            Else
                                lCountEachItem = lCountEachItem - 1
                            End If
                        Next
                    End If

                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
            End If
        Else
            MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If

    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
    Else
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
        blnIsEnd = True
    End If

PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim lNum As Long

    lNum = SaveAttachmentsFromSelection

    If lNum > 0 Then
        MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
End Sub

选项显式
' *****************
展望2010。
' *****************
#如果是VBA7，则
'Outlook的窗口句柄。
作为LongPtr的私有lHwnd
'/*API声明*/
私有声明PtrSafe函数findwindowlib“user32”别名“FindWindowA”（ByVal lpClassName作为字符串_
ByVal lpWindowName（作为字符串）作为LongPtr
' *****************************************
'用于Outlook 2010的早期版本。
' *****************************************
#否则
'Outlook的窗口句柄。
二等兵长
'/*API声明*/
私有声明函数findwindowlib“user32”别名“FindWindowA”（ByVal lpClassName作为字符串_
ByVal lpWindowName（作为字符串）长度相同
#如果结束
'Outlook窗口的类名。
Private Const olAppCLSN As String=“rctrl\u renwnd32”
'Windows desktop-作为命名空间根的虚拟文件夹。
私有Const CSIDL_DESKTOP=&H0
'仅返回文件系统目录。如果用户选择的文件夹不是文件系统的一部分，则“确定”按钮呈灰色。
私有常量BIF_RETURNONLYFSDIRS=&H1
'不要在对话框的树状视图控件中包含域级别以下的网络文件夹。
私有常量BIF_DONTGOBELOWDOMAIN=&H2
'路径的最大长度为260个字符。
私有常量最大路径=260
' ######################################################
'返回所选内容中的附件数。
' ######################################################
公共函数SaveAttachmentsFromSelection（）的长度为
将objFSO设置为对象的计算机文件系统对象。
将objShell作为对象的Windows Shell应用程序对象进行调整。
Dim objFolder As Object“从“浏览文件夹”对话框中选择的文件夹对象。
Dim objItem As Object“按位置或键指定集合对象的特定成员。
Dim selItems As Selection文件夹中Outlook项目对象的集合。
将atmt设置为附件“Outlook项目中包含的文档或文档链接。
Dim StratmPath作为字符串“附件的完整保存路径”。
Dim StratmFullName As String'附件的全名。
Dim strAtmtName（1）作为字符串'strAtmtName（0）：保存名称；strAtmtName（1）：保存文件扩展名。它们由附件文件名的点分隔。
Dim strAtmtNameTemp As String'以保存临时附件文件名。
Dim intDotPosition As Integer'附件名称中的点位置。
Dim atmts As Attachments’表示Outlook项目中的附件的一组附件对象。
Dim lCountEachItem，只要“每个Outlook项目中的附件数”。
Dim lCountAllItems作为“所有Outlook项目中的附件数”。
将strFolderPath设置为字符串“选定文件夹路径”。
将blnIsEnd设置为布尔值“结束所有代码执行”。
DimeBLNISStaveBoobe作为“布尔”考虑是否需要保存。
blnIsEnd=False
blnisave=False
lCountAllItems=0
出错时继续下一步
设置selItems=ActiveExplorer.Selection
如果Err.Number=0，则
'获取Outlook窗口的句柄。
lHwnd=FindWindow（olAppCLSN，vbNullString）
如果lHwnd为0，则
“/*创建一个Shell应用程序对象以弹出BrowseForFolder对话框*/
设置objShell=CreateObject（“Shell.Application”）
设置objFSO=CreateObject（“Scripting.FileSystemObject”）
设置objFolder=objShell.BrowseForFolder（lHwnd，“选择要保存附件的文件夹：”_
BIF_RETURNONLYFSDIRS+BIF_DONTGOBELOWDOMAIN，CSIDL_桌面）
“/*未能创建外壳程序应用程序*/
如果错误号为0，则
MsgBox“运行时错误”&CStr（错误号）&“（0x”&CStr（十六进制（错误号））&”）：“&vbNewLine&_
错误说明&“，”vbCritical，“附件保护程序错误”
blnIsEnd=True
转到程序出口
如果结束
如果objFolder为空，则
strFolderPath=“”
blnIsEnd=True
转到程序出口
其他的
strFolderPath=CGPath（objFolder.Self.Path）
“/*检查所选内容中的每个项目*/
对于selItems中的每个objItem
lCountEachItem=objItem.Attachments.Count
“/*如果当前项包含附件*/
如果lCountEachItem>0，则
设置atmts=objItem.Attachments
“/*浏览当前项目中的每个附件*/
对于atmt中的每个atmt
'获取当前附件的全名。
strAtmtFullName=atmt.FileName
'在atmtFullName中查找点位置。
intDotPosition=InStrRev（strAtmtFullName，“.”）
“知道名字了。
strAtmtName（0）=左$（strAtmtFullName，intDotPosition-1）
'获取文件扩展名。
strAtmtName（1）=右$（strAtmtFullName，Len（strAtmtFullName）-intDotPosition）
'获取当前附件的完整保存路径。
strAtmtPath=strFolderPath&atmt.FileName
strAtmtPath = strFolderPath & objItem.SenderEmailAddress & "-" & atmt.FileName

Dim SndrName            As String

          For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count
                SndrName = objItem.SenderName & "_"  ' <--- Add this

                      ' Get the full saving path of the current attachment.
                        strAtmtPath = strFolderPath & SndrName & atmt.FileName '