如何保存Outlook中用VBA生成的文本文件？

问题描述 #

我有一段从Outlook邮件正文提取URL并生成文本文件的VBA代码，但无法保存文件。尝试用xTextfile.save无效，移除On Error Resume Next后，执行xTextFile.WriteLine (xUrl & vbCrLf)时出现“对象变量或With块变量未设置”的运行时错误，请问该如何解决？

原代码 #

Sub ExportUrlToTextFileFromEmail()
    'UpdatebyExtendoffice20220413
    Dim xMail As Outlook.MailItem
    Dim xRegExp As RegExp
    Dim xMatchCollection As MatchCollection
    Dim xMatch As Match
    Dim xUrl As String, xSubject As String, xFileName As String
    Dim xFs As FileSystemObject
    Dim xTextFile As Object
    Dim i As Integer
    Dim InvalidArr
    
    If Application.ActiveWindow.Class = olInspector Then
        Set xMail = ActiveInspector.CurrentItem
    ElseIf Application.ActiveWindow.Class = olExplorer Then
        Set xMail = ActiveExplorer.Selection.Item(1)
    End If
    Set xRegExp = New RegExp
    With xRegExp
        .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
        .Global = True
        .IgnoreCase = True
    End With
    If xRegExp.test(xMail.Body) Then
        InvalidArr = Array("/", "\\", "*", ":", Chr(34), "?", "<", ">", "|")
        xSubject = xMail.Subject
        For i = 0 To UBound(InvalidArr)
            xSubject = VBA.Replace(xSubject, InvalidArr(i), "")
        Next i
        xFileName = "Z:\" & xSubject & ".txt"
        Set xFs = CreateObject("Scripting.FileSystemObject")
        Set xTextFile = xFs.CreateTextFile(xFileName, True)
        xTextFile.WriteLine (vbCrLf)
        Set xMatchCollection = xRegExp.Execute(xMail.Body)
        i = 0
        For Each xMatch In xMatchCollection
            xUrl = xMatch.SubMatches(0)
            i = i + 1
            'xTextFile.WriteLine (i & ". " & xUrl & vbCrLf)
            xTextFile.WriteLine (xUrl & vbCrLf)
        Next
        xTextFile.Close
        Set xTextFile = Nothing
        Set xMatchCollection = Nothing
        Set xFs = Nothing
        Set xFolderItem = CreateObject("Shell.Application").Namespace(0).ParseName(xFileName)
        xFolderItem.InvokeVerbEx ("open")
        Set xFolderItem = Nothing
    End If
    Set xRegExp = Nothing
End Sub

错误原因分析 #

• 核心问题：xTextFile未成功初始化。当Z:盘不存在、路径无写入权限，或者生成的文件名存在隐性问题时，xFs.CreateTextFile执行失败，导致xTextFile为Nothing，后续调用WriteLine触发“对象未设置”错误。
• 次要问题：代码未处理xMail为Nothing的情况（比如未选中任何邮件、当前窗口不是Outlook的Inspector/Explorer），会导致后续xRegExp.test(xMail.Body)直接报错。

修正后的代码 #

Sub ExportUrlToTextFileFromEmail()
    'UpdatebyExtendoffice20220413 | 修正文件保存问题
    Dim xMail As Outlook.MailItem
    Dim xRegExp As RegExp
    Dim xMatchCollection As MatchCollection
    Dim xMatch As Match
    Dim xUrl As String, xSubject As String, xFileName As String
    Dim xFs As FileSystemObject
    Dim xTextFile As Object
    Dim i As Integer
    Dim InvalidArr
    
    ' 检查是否选中邮件或打开邮件窗口
    Set xMail = Nothing
    If Application.ActiveWindow.Class = olInspector Then
        Set xMail = ActiveInspector.CurrentItem
    ElseIf Application.ActiveWindow.Class = olExplorer Then
        If ActiveExplorer.Selection.Count > 0 Then
            Set xMail = ActiveExplorer.Selection.Item(1)
        End If
    End If
    If xMail Is Nothing Then
        MsgBox "请先选中一封邮件或打开邮件窗口！", vbExclamation
        Exit Sub
    End If
    
    ' 初始化正则表达式
    Set xRegExp = New RegExp
    With xRegExp
        .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
        .Global = True
        .IgnoreCase = True
    End With
    
    ' 检查邮件正文是否包含URL
    If Not xRegExp.test(xMail.Body) Then
        MsgBox "邮件正文中未找到URL！", vbInformation
        Exit Sub
    End If
    
    ' 处理文件名，移除非法字符
    InvalidArr = Array("/", "\\", "*", ":", Chr(34), "?", "<", ">", "|")
    xSubject = xMail.Subject
    For i = 0 To UBound(InvalidArr)
        xSubject = VBA.Replace(xSubject, InvalidArr(i), "")
    Next i
    ' 避免空文件名
    If xSubject = "" Then xSubject = "无标题邮件"
    xFileName = "Z:\" & xSubject & ".txt"
    
    ' 初始化文件系统对象并检查路径
    Set xFs = CreateObject("Scripting.FileSystemObject")
    ' 检查Z盘是否存在
    If Not xFs.DriveExists("Z:") Then
        MsgBox "Z盘不存在，请确认磁盘映射或路径正确性！", vbCritical
        Set xFs = Nothing
        Exit Sub
    End If
    
    ' 创建文本文件并检查是否成功
    On Error Resume Next
    Set xTextFile = xFs.CreateTextFile(xFileName, True)
    On Error GoTo 0
    If xTextFile Is Nothing Then
        MsgBox "无法创建文件：" & xFileName & vbCrLf & "请检查路径权限或文件名是否合法！", vbCritical
        Set xFs = Nothing
        Exit Sub
    End If
    
    ' 写入URL到文本文件
    xTextFile.WriteLine vbCrLf ' 空行分隔
    Set xMatchCollection = xRegExp.Execute(xMail.Body)
    i = 0
    For Each xMatch In xMatchCollection
        xUrl = xMatch.SubMatches(0)
        i = i + 1
        xTextFile.WriteLine xUrl & vbCrLf ' 去掉多余括号，规范写法
    Next
    
    ' 关闭文件并尝试打开
    xTextFile.Close
    Set xTextFile = Nothing
    Set xMatchCollection = Nothing
    Set xFs = Nothing
    
    On Error Resume Next
    Set xFolderItem = CreateObject("Shell.Application").Namespace(0).ParseName(xFileName)
    If Not xFolderItem Is Nothing Then
        xFolderItem.InvokeVerbEx "open"
    Else
        MsgBox "文件已保存，但无法自动打开：" & xFileName, vbInformation
    End If
    Set xFolderItem = Nothing
    
    Set xRegExp = Nothing
    MsgBox "URL已成功导出到：" & xFileName, vbInformation
End Sub

关键修改说明 #

• 增加邮件选中状态检查，避免xMail为空导致后续报错
• 提前验证目标磁盘（Z盘）是否存在，从源头避免文件创建失败
• 增加文件创建结果校验，及时提示路径权限或文件名问题
• 处理空邮件主题的情况，避免生成无效文件名
• 优化错误捕获逻辑，给出明确的用户提示
• 规范WriteLine写法，移除多余括号减少语法歧义

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