自动保存仅以文件夹名称开头的电子邮件

Question

我编译了这个由规则触发的脚本，以在电子邮件 (DCSXXXX) 中查找参考号（在 Outlook 中使用 VBA）并将此电子邮件保存在同名文件夹。

但是，如果文件夹名称为 "DCSXXX [any text]"，我试图找到一种让脚本工作的方法，这意味着我只有文件夹的开头使用的名称。有什么想法吗？

Public Sub GetValueUsingRegEx(myItem As MailItem)
' Set reference to VB Script library
' Microsoft VBScript Regular Expressions 5.5

    Dim olMail As Outlook.MailItem
    Dim Reg1 As RegExp
    Dim colMatches As matchCollection
    Dim M1 As Match
    Dim Path As String
    Dim enviro As String
    Dim Match As String

    Path = "X:\Path"

    Set olMail = myItem

    Set Reg1 = New RegExp

    Reg1.IgnoreCase = True
    Reg1.Pattern = "DCS\d\d\d\d\d?"
    Reg1.Global = False

    If Reg1.test(olMail.Body) Then

        Set colMatches = Reg1.Execute(olMail.Body)
        Match = Reg1.Execute(olMail.Body)(0)

        For Each M1 In colMatches
            MsgBox (M1)
        Next

    End If

    Subject = olMail.Subject
    Subject = Replace(Subject, ":", "_")
    fullPath = (Path & "" & Match & "" & Subject & ".msg")

    olMail.SaveAs (fullPath)
    MsgBox fullPath
    MsgBox Match
    MsgBox Subject
    MsgBox ("Done")

End Sub

Answer 1

在保存之前获取完整路径，这是使用Dir Function的快速示例

        Dim Path As String
            Path = "X:\Path\"

        Dim FldrName As String
            FldrName = Match

            On Error Resume Next
            Dim sGetPath As String
            sGetPath = Path & Match & "*"

            FldrName = Dir(sGetPath, vbDirectory)

        Dim SavePath As String
            SavePath = Path & FldrName & "\"

或使用函数 - 完整示例

Option Explicit
Public Sub Example(Item As Outlook.mailitem)
    Dim Email As Outlook.mailitem
    Dim Matches As Variant
    Dim RegExp As New RegExp
    Dim Pattern As String

    If TypeOf Item Is Outlook.mailitem Then
        Pattern = "DCS\d\d\d\d\d?"
        With RegExp
            .Global = False
            .Pattern = Pattern
            .IgnoreCase = True
             Set Matches = .Execute(Item.Body)
        End With

        If Matches.Count > 0 Then
            Debug.Print Item.Subject ' Print on Immediate Window
            Debug.Print Matches(0)

            Dim Subject As String
                Subject = Item.Subject
                Subject = Replace(Subject, ":", "_")

            Dim Path As String
                Path = "C:\Temp\"

            Dim FldrName As String
                FldrName = Matches(0)

            Dim SavePath As String
                SavePath = FullPath(FldrName, Path)

                Debug.Print SavePath

            Item.SaveAs SavePath & Subject & ".msg", olMsg

        End If
    End If

    Set RegExp = Nothing
    Set Matches = Nothing
    Set Email = Nothing
    Set Item = Nothing
End Sub

Private Function FullPath(ByVal FldrName As String, _
                                 ByVal Path As String)
    Dim sGetPath As String

    On Error Resume Next
    sGetPath = Path & FldrName & "*"

    Debug.Print sGetPath

    FldrName = Dir(sGetPath, vbDirectory)

    Do While Len(FldrName) > 0
        If Left(FldrName, 1) <> "" Then
            If (GetAttr(FldrName) And vbDirectory) = vbDirectory Then
                Debug.Print FldrName
                FullPath = Path & FldrName & "\"
                Debug.Print FullPath
                Exit Do
            End If
        End If
        FldrName = Dir
    Loop

    If FullPath = Empty Then MsgBox "Folder Not Found"

End Function

Answer 2

如果我理解正确，您想去掉多余的文字吗？您可以像这样使用拆分功能：

Subject = olMail.Subject
Subject = Replace(Subject, ":", "_")
Subject = Split(Subject, " ")(0)

这应该只给你DCSXXX 部分。

Split 函数使用Delimiter（在本例中为空格字符）返回Array。在它返回一个String 之后直接放置一个(0) 等于Array 中的第一项

你也可以把它简化成这样的一行：

Subject = Split(Replace(olMail.Subject, ":", "_"), " ")(0)

但是想一想，因为Split 无论如何都会消除第一个空格之后的所有内容，所以可能不需要使用Replace 将: 更改为_.... 对吗？

Subject = Split(olMail.Subject, " ")(0)