如何修改Outlook VBA脚本实现按文件名前缀分类保存附件

需求说明 #

现有Outlook VBA脚本已实现自动打印邮件附件功能，需新增以下功能：

• 仅处理以四位数字开头的.docx格式工单附件（例如1200‑john_doe‑job1.docx）
• 按规则保存至指定目录：
  • 根目录固定为C:\work orders
  • 一级文件夹按工单编号区间划分（如1200-1299、1300-1399），通过提取文件名前两位数字确定对应区间
  • 最终附件保存至以四位数字开头的子文件夹（如1256-randomtext），示例路径：C:\work orders\1200-1299\1256-randomtext\1200‑john_doe‑job1.docx

修改后的完整VBA代码 #

Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
  (ByVal lpAppName As String, ByVal lpKeyName As String, _
  ByVal lpDefault As String, ByVal lpReturnedString As String, _
  ByVal nSize As Long) As Long
                  
Private Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
                  
Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
  Optional bolPrintMsg As Boolean, _
  Optional bolSaveMsg As Boolean, _
  Optional bolPrintAtt As Boolean, _
  Optional bolSaveAtt As Boolean, _
  Optional bolInsertLink As Boolean, _
  Optional strAttFileTypes As String, _
  Optional strFolderPath As String, _
  Optional varMsgFormat As OlSaveAsType, _
  Optional strPrinter As String, _
  Optional bolSaveWorkOrder As Boolean) '新增参数控制工单保存
                     
    Dim olkAttachment As Outlook.Attachment, _
      objFSO As FileSystemObject, _
      strMyPath As String, _
      strExtension As String, _
      strFileName As String, _
      strOriginalPrinter As String, _
      strLinkText As String, _
      strRootFolder As String, _
      strTempFolder As String, _
      varFileType As Variant, _
      intCount As Integer, _
      intIndex As Integer, _
      arrFileTypes As Variant, _
      '新增工单处理变量
      strWOFileName As String, _
      strWOPrefix4 As String, _
      strWOPrefix2 As String, _
      strWOIntervalFolder As String, _
      strWOSubFolder As String, _
      strWOFullPath As String
                  
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFolder = Environ("TEMP") & "\"
                       
    If strAttFileTypes = "" Then
        arrFileTypes = Array("*")
    Else
        arrFileTypes = Split(strAttFileTypes, ",")
    End If
    
    If bolPrintMsg Or bolPrintAtt Then
        If strPrinter <> "" Then
            strOriginalPrinter = GetDefaultPrinter()
            SetDefaultPrinter strPrinter
        End If
    End If
                       
    If bolSaveMsg Or bolSaveAtt Then
        If strFolderPath = "" Then
            strRootFolder = Environ("USERPROFILE") & "\My Documents\"
        Else
            strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
        End If
    End If
                       
    If bolSaveMsg Then
        Select Case varMsgFormat
            Case olHTML
                strExtension = ".html"
            Case olMSG
                strExtension = ".msg"
            Case olRTF
                strExtension = ".rtf"
            Case olDoc
                strExtension = ".doc"
            Case olTXT
                strExtension = ".txt"
            Case Else
                strExtension = ".msg"
        End Select
        Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, varMsgFormat
    End If
                           
    For intIndex = Item.Attachments.Count To 1 Step -1
        Set olkAttachment = Item.Attachments.Item(intIndex)
        'Print the attachments if requested'
        If bolPrintAtt Then
            If olkAttachment.Type <> olEmbeddeditem Then
                For Each varFileType In arrFileTypes
                    If (varFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(varFileType)) Then
                        olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
                        ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
                    End If
                Next
            End If
        End If
        
        '新增：工单附件保存逻辑'
        If bolSaveWorkOrder Then
            strFileName = olkAttachment.FileName
            '仅处理docx格式且文件名以四位数字开头的附件'
            If LCase(objFSO.GetExtensionName(strFileName)) = "docx" And IsNumeric(Left(strFileName, 4)) Then
                '提取四位前缀和两位前缀'
                strWOPrefix4 = Left(strFileName, 4)
                strWOPrefix2 = Left(strWOPrefix4, 2)
                '构造区间文件夹名'
                strWOIntervalFolder = strWOPrefix2 & "00-" & strWOPrefix2 & "99"
                '构造子文件夹名（取文件名中第一个分隔符前的部分，或直接用四位前缀+后续文本）'
                If InStr(strFileName, "-") > 0 Then
                    strWOSubFolder = Left(strFileName, InStr(strFileName, ".") - 1)
                Else
                    strWOSubFolder = strWOPrefix4
                End If
                '构造完整路径'
                strWOFullPath = "C:\work orders\" & strWOIntervalFolder & "\" & strWOSubFolder & "\"
                
                '创建目录（如果不存在）'
                If Not objFSO.FolderExists(strWOFullPath) Then
                    objFSO.CreateFolder strWOFullPath
                End If
                
                '处理文件名重复'
                strWOFileName = strFileName
                intCount = 0
                Do While objFSO.FileExists(strWOFullPath & strWOFileName)
                    intCount = intCount + 1
                    strWOFileName = "Copy (" & intCount & ") of " & strFileName
                Loop
                
                '保存附件'
                olkAttachment.SaveAsFile strWOFullPath & strWOFileName
                
                '如果需要插入链接，可复用原有逻辑'
                If bolInsertLink Then
                    If Item.BodyFormat = olFormatHTML Then
                        strLinkText = strLinkText & "<a href=""file://" & strWOFullPath & strWOFileName & """>" & olkAttachment.FileName & "</a><br>"
                    Else
                        strLinkText = strLinkText & strWOFullPath & strWOFileName & vbCrLf
                    End If
                    olkAttachment.Delete
                End If
            End If
        End If
        
        '原有保存附件逻辑（非工单附件）'
        If bolSaveAtt And Not bolSaveWorkOrder Then
            strFileName = olkAttachment.FileName
            intCount = 0
            Do While True
                strMyPath = strRootFolder & strFileName
                If objFSO.FileExists(strMyPath) Then
                    intCount = intCount + 1
                    strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strMyPath
            If bolInsertLink Then
                If Item.BodyFormat = olFormatHTML Then
                    strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
                Else
                    strLinkText = strLinkText & strMyPath & vbCrLf
                End If
                olkAttachment.Delete
            End If
        End If
    Next
                       
    If bolPrintMsg Then
        Item.PrintOut
    End If
                       
    If bolPrintMsg Or bolPrintAtt Then
        If strOriginalPrinter <> "" Then
            SetDefaultPrinter strOriginalPrinter
        End If
    End If
                       
    If bolInsertLink Then
        If Item.BodyFormat = olFormatHTML Then
            Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
        Else
            Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
        End If
        Item.Save
    End If
                  
    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub
                  
Function GetDefaultPrinter() As String
    Dim strPrinter As String, _
      intReturn As Integer
    strPrinter = Space(255)
    intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
    If intReturn Then
        strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
    End If
    GetDefaultPrinter = strPrinter
End Function
                  
Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

Sub SetDefaultPrinter(strPrinterName As String)
    Dim objNet As Object
    Set objNet = CreateObject("Wscript.Network")
    objNet.SetDefaultPrinter strPrinterName
    Set objNet = Nothing
End Sub
                  
Sub AutoprintAndSaveWorkOrders(Item As Outlook.MailItem)
    '调用时开启打印和工单保存功能'
    MessageAndAttachmentProcessor Item, False, False, True, False, False, "doc,docx", , , , True
End Sub

关键修改说明 #

1. 新增参数：为MessageAndAttachmentProcessor添加bolSaveWorkOrder参数，用于独立开关工单附件保存功能
2. 附件筛选逻辑：仅处理.docx格式且文件名前四位为数字的工单附件
3. 路径自动构造：
   • 提取文件名前两位数字生成区间文件夹名（如1200-1299）
   • 提取文件名中从开头到第一个.的部分作为子文件夹名（如1256-randomtext）
4. 目录自动创建：使用FileSystemObject自动生成不存在的层级目录
5. 重名处理：对重复文件名自动添加Copy (N)后缀，避免覆盖
6. 新增调用宏：AutoprintAndSaveWorkOrders可直接绑定到Outlook规则，同时触发附件打印和工单保存

内容的提问来源于stack exchange，提问作者Robert Rickard