Question

我正在开展一个项目，要求我将大量附件保存到文件夹并过滤它们。

我目前可以使用电子邮件的主题保存附件作为文件名。如果有超过1个附件，则它将作为主题行保存为（1）或（2），依此类推。

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

我需要完成此脚本的最后一件事是在使用主题行作为文件名之前，将省略主题行中的特殊字符。我遇到的问题是如果主题是转发（FW :)或回复（RE :)，程序不能正确保存文件我怀疑＆＃34;：＆＃34;是什么打破了保存文件。例如，如果主题读取＆＃34; FW：这是您要求的文件2017＆＃34;我得到的是一个文件保存为＆＃34; FW＆＃34;没有文件扩展名。我需要的是删除＆＃34;：＆＃34;或者＆＃34; FW：＆＃34;所以这不会发生。

当有人转换为保存文件名时，有人可以向我提供从主题中删除特殊字符所需的更正吗？

我认为需要一个数组才能实现这个目标，但我不确定如何将其填充以及将其添加到脚本的哪个部分。

像Array这样的东西（＆＃34;＆lt;＆＃34;，＆＃34;＆gt;＆＃34;，＆＃34; |＆＃34;，＆＃34; /＆＃34;，＆＃34; *＆＃34;，＆＃34; \＆＃34;，＆＃34;？＆＃34;，＆＃34;＆＃34;＆＃34;＆＃34;，＆＃34; ＆＃39;＆＃34;，＆＃34;：＆＃34;）

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

经过一些挖掘，看了几个可选的选项，从主题栏中省略了特殊字符，还有一些玩弄了宏，我已经想出了什么样的接缝能够完美地满足我的需要。

感谢0m3r为您提供初步帮助以获得照顾。

以下代码：

选择要保存所有附件的文件夹。
然后拉出每封电子邮件的主题行
用＆＃34; _＆＃34;
将文件另存为修改后的主题行。
为每个选定的电子邮件重复处理。

粘贴：

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

Answer 2

您需要修改 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

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

2 个答案: