SubMatches函数VBA中的运行时错误

时间:2019-06-13 06:26:52

标签: vba outlook

我正在尝试使用VBA中的regex表达式从邮件正文中找到某个字符串及其关联的值,但我得到了Runtime error 5 Invalid procedure call or argument,但找不到解决方案。

MsgBox M.SubMatches(1)行出现错误

总体而言,我正在尝试将整个电子邮件以及所有附件导出为PDF到特定文件夹。我想将PDF命名为从正则表达式中找到的值。

Sub SaveWithoutBox()

    'Get all selected items
    Dim MyOlNamespace As Outlook.NameSpace
    Set MyOlNamespace = Application.GetNamespace("MAPI")
    Set MyOlSelection = Application.ActiveExplorer.Selection

    'Make sure at least one item is selected
    If MyOlSelection.Count <> 1 Then
       Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF")
       Exit Sub
    End If

    'Retrieve the selected item
    Set MySelectedItem = MyOlSelection.Item(1)

    'Get the user's TempFolder to store the item in
    Dim FSO As Object, TmpFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set tmpFileName = FSO.GetSpecialFolder(2)

    'construct the filename for the temp mht-file
    strName = "shanilsoni"
    tmpFileName = tmpFileName & "\" & strName & ".mht"

    'Save the mht-file
    MySelectedItem.SaveAs tmpFileName, olMHTML

    'Open the mht file in MS Word
    Set objWordApp = CreateObject("Word.Application")
    Set objWordDoc = objWordApp.Documents.Open(tmpFileName, False)

    'Set file name to subject
    Dim msgFileName As String
    msgFileName = MySelectedItem.Subject

    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim filenameregex As String
    Set Reg1 = New RegExp
    With Reg1
        'Demo string: "Reference number: US8617687AHSJ918
        .Pattern = "Reference number:+\s*(\w*)\s*"
        .Global = True
    End With

    If Reg1.test(MySelectedItem.Body) Then
        Set M1 = Reg1.Execute(MySelectedItem.Body)
        For Each M In M1
            MsgBox M.SubMatches(1) 'Error coming here in debugging
            Set filenameregex = M.SubMatches(1)
        Next
    End If

    'Change the local folder to save the PDF file
    strPDF = "D:\Test\" & filenameregex & ".pdf"

    'Export the current mht file as a PDF file
    objWordApp.ActiveDocument.ExportAsFixedFormat strPDF, wdExportFormatPDF

    objWordDoc.Close
    objWordApp.Quit

    'Cleanup
    Set MyOlNamespace = Nothing
    Set MyOlSelection = Nothing
    Set MySelectedItem = Nothing
    Set objWordDoc = Nothing
    Set objWordApp = Nothing

    Dim individualItem As Object
    Dim att As Attachment
    Dim strPath As String
    Dim dicFileNames As Object

    strPath = "D:\Test\"

    Set dicFileNames = CreateObject("Scripting.Dictionary")

    For Each individualItem In Application.ActiveExplorer.Selection
        If TypeName(individualItem) = "MailItem" Then
            Dim j As Integer
            j = 1
            For Each att In individualItem.Attachments
                dicFileNames.Add att.FileName, 1
                att.SaveAsFile strPath & att.FileName
            Next att
        End If
    Next individualItem

End Sub

任何帮助将不胜感激。

0 个答案:

没有答案