如何从 Outlook 中提取附件、另存为主题行并删除无效字符？

Question

我正在做一个项目，需要我将大量附件保存到一个文件夹并对其进行过滤。

我目前可以保存以邮件主题为文件名的附件。如果有超过 1 个附件，则将其保存为带有 (1) 或 (2) 等的主题行。

我目前有一个脚本可以完成我需要的大部分工作（感谢下面回复中 0m3r 的帮助）

我需要完成此脚本的最后一件事是在使用主题行作为文件名之前从主题行中省略特殊字符。我运行遇到的问题是，如果主题是转发 (FW:) 或回复 (RE:)，程序无法正确保存文件我怀疑“:”是破坏保存文件的原因。例如，如果主题读取 "FW: Here is the file you requested 2017" 我得到的是一个保存为 "FW" 的文件，没有文件扩展名。我需要的是删除“：”或 "FW:" 这样就不会发生这种情况。

谁能提供我需要从主题中删除特殊字符的更正，因为它已转换为保存文件名？

我认为需要一个数组来完成这个，但我不确定如何植入它以及将它添加到脚本的哪一部分。

类似于 Array("<", ">", "|", "/", "*", "\", "?", """", "'", ":")

Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object       
Dim objShell            As Object       
Dim objFolder           As Object       
Dim objItem             As Object       
Dim selItems            As Selection    
Dim atmt                As Attachment   
Dim strAtmtPath         As String       
Dim strAtmtFullName     As String       
Dim strAtmtName         As String       
Dim strAtmtNameTemp     As String       
Dim intDotPosition      As Integer      
Dim atmts               As Attachments  
Dim lCountEachItem      As Long         
Dim lCountAllItems      As Long         
Dim strFolderPath       As String       
Dim blnIsEnd            As Boolean      
Dim blnIsSave           As Boolean      

blnIsEnd = False
blnIsSave = False
lCountAllItems = 0

On Error Resume Next

Set selItems = ActiveExplorer.Selection

If Err.Number = 0 Then

    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

        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)

        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)

            For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count

                If lCountEachItem > 0 Then
                    Set atmts = objItem.Attachments

                    For Each atmt In atmts
                        strAtmtFullName = atmt.FileName
                        intDotPosition = InStrRev(strAtmtFullName, ".")
                        strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                        strAtmtPath = strFolderPath & objItem.subject & Chr(46) & strAtmtName

                        Dim lngF As Long
                        lngF = 1

                        If Len(strAtmtPath) <= MAX_PATH Then
                            blnIsSave = True
                            Do While objFSO.FileExists(strAtmtPath)

                                strAtmtNameTemp = objItem.subject & "(" & lngF & ")"

                                strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName

                                If Len(strAtmtPath) > MAX_PATH Then
                                    lCountEachItem = lCountEachItem - 1
                                    blnIsSave = False
                                    Exit Do
                                End If

                            lngF = lngF + 1
                            Loop

                            If blnIsSave Then atmt.SaveAsFile strAtmtPath
                        Else
                            lCountEachItem = lCountEachItem - 1
                        End If
                    Next
                End If

                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

Else
    MsgBox "Please select an Outlook item at least.",  vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If

PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems

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

If blnIsEnd Then End
End Function

Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function

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

Answer 1

您需要修改您的 For Each loop，试试这个...

改变这个

Dim strAtmtName(1)      As String

对此

Dim strAtmtName         As String

然后像这样修改你的For Each loop

For Each Atmt In atmts
    strAtmtFullName = Atmt.FileName
    intDotPosition = InStrRev(strAtmtFullName, ".")
    strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
    strAtmtPath = strFolderPath & objItem.Subject & Chr(46) & strAtmtName

    Dim lngF As Long
    lngF = 1

    If Len(strAtmtPath) <= MAX_PATH Then
        blnIsSave = True
        Do While objFSO.FileExists(strAtmtPath)

            strAtmtNameTemp = objItem.Subject & "(" & lngF & ")"

            strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName

            If Len(strAtmtPath) > MAX_PATH Then
                lCountEachItem = lCountEachItem - 1
                blnIsSave = False
                Exit Do
            End If

            lngF = lngF + 1
        Loop

Answer 2

在仔细研究了几个从主题行中省略特殊字符的可能选项以及对宏进行了一些尝试之后，我想出了哪些接缝可以完美地满足我的需要。

感谢 0m3r 的初步帮助，让这个问题得到解决。

代码如下：

选择要保存所有附件的文件夹。
然后提取每封电子邮件的主题行
用“_”替换我定义的任何特殊字符
将文件保存为修改后的主题行。
对每个选定的电子邮件重复该过程。

粘贴：

Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object
Dim objShell            As Object
Dim objFolder           As Object
Dim objItem             As Outlook.MailItem
Dim selItems            As Selection
Dim atmt                As Attachment
Dim strAtmtPath         As String
Dim strAtmtFullName     As String
Dim strAtmtName         As String
Dim strAtmtNameTemp     As String
Dim intDotPosition      As Integer
Dim atmts               As Attachments
Dim lCountEachItem      As Long
Dim lCountAllItems      As Long
Dim strFolderPath       As String
Dim blnIsEnd            As Boolean
Dim blnIsSave           As Boolean
Dim strPrompt           As String, strname As String
Dim sreplace            As String, mychar As Variant
 blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
    lHwnd = FindWindow(olAppCLSN, vbNullString)
    If lHwnd <> 0 Then
        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)
        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)
            For Each objItem In selItems
                lCountEachItem = objItem.Attachments.Count
                If lCountEachItem > 0 Then
                    Set atmts = objItem.Attachments

                    If objItem.Class = olMail Then
                        If objItem.subject <> vbNullString Then
                            strname = objItem.subject
                        Else
                            strname = "No_Subject"
                        End If
                    sreplace = "_"
                    For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
                    'do the replacement for each character that's illegal
                        strname = Replace(strname, mychar, sreplace)
                    Next mychar
                    End If
                    For Each atmt In atmts
                        strAtmtFullName = atmt.FileName
                        intDotPosition = InStrRev(strAtmtFullName, ".")
                        strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                        strAtmtPath = strFolderPath & strname & Chr(46) & strAtmtName
                        Dim lngF As Long
                        lngF = 1
                        If Len(strAtmtPath) <= MAX_PATH Then
                            blnIsSave = True
                            Do While objFSO.FileExists(strAtmtPath)
                                strAtmtNameTemp = strname & "(" & lngF & ")"
                                strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName
                                If Len(strAtmtPath) > MAX_PATH Then
                                    lCountEachItem = lCountEachItem - 1
                                    blnIsSave = False
                                    Exit Do
                                End If
                            lngF = lngF + 1
                            Loop
                            If blnIsSave Then atmt.SaveAsFile strAtmtPath
                        Else
                            lCountEachItem = lCountEachItem - 1
                        End If
                    Next
                End If
                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   
Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
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
If blnIsEnd Then End
End Function
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
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

编辑：

用于 API 声明的脚本部分，这些声明需要使该脚本在 outlooks VBA 中工作。这部分代码位于 Public Function SaveAttachmentsFromSelection() As Long

行上方声明所有变量之前

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

如何从 Outlook 中提取附件、另存为主题行并删除无效字符？

How can I extract attachments from Outlook, save as subject line and remove invalid characters?

outlook

vba

attachment

special-characters