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

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

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

我目前有一个脚本可以完成我需要的大部分功能(感谢下面回复中 0m3r 的帮助)

完成此脚本所需的最后一件事是在使用主题行作为文件名之前从主题行中省略特殊字符。我遇到的问题是，如果主题是转发 (FW:) 或回复 (RE:)，则程序无法正确保存文件，我怀疑“:”是破坏保存文件的原因。例如，如果主题为“FW:这是您在 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

最佳答案

经过一番挖掘，研究了从主题行中省略特殊字符的几种可能选项，并尝试了一些宏，我想出了哪些接缝可以完美地满足我的需要。

感谢 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 声明的脚本部分，需要这些声明才能使该脚本在 Outlook 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

关于vba - 如何从 Outlook 中提取附件、另存为主题行并删除无效字符？，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/41989240/

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

上一篇：neural-network - 本教程中的神经网络拦截偏差

下一篇：Python Flask jinja2 模板变量上下文。无法渲染变量