Outlook VBA脚本无法保存邮件至固定网络驱动器（非映射驱动器）的问题求助

大家好，我在使用Outlook VBA脚本保存邮件时遇到了麻烦，希望能得到大家的帮助！

我需要定期将某个客户发来的邮件保存到本地硬盘上按当前日期命名的文件夹中。我找到了一段可以选择或创建文件夹的代码，但运行时出现了几个问题：

• 我想要保存到的固定网络驱动器不在脚本的可选文件夹列表里；当我浏览到存放目标邮件的文件夹后，脚本会提示我选择另一个保存文件夹，虽然能创建新文件夹，但创建完成后就报错了
• 具体错误是：Run-time error code '76': Path not found
• 奇怪的是，新文件夹明明已经在文件资源管理器里显示出来了，但脚本检查路径时并没有指向这个刚创建的路径
• 补充一下，我们团队使用固定网络驱动器而非映射驱动器，因为远程工作时映射驱动器无法正常访问

我的核心需求其实很明确：在指定位置（本地硬盘或固定网络驱动器）创建一个文件夹，将选中的邮件（如果能按发件人筛选会更方便）保存进去。

下面是我使用的代码：

Option Explicit

Sub SaveAllEmails_ProcessAllSubFolders()

Dim i               As Long

Dim j               As Long

Dim n               As Long

Dim StrSubject      As String

Dim StrName         As String

Dim StrFile         As String

Dim StrReceived     As String

Dim StrSavePath     As String

Dim StrFolder       As String

Dim StrFolderPath   As String

Dim StrSaveFolder   As String

Dim Prompt          As String

Dim Title           As String

Dim iNameSpace      As NameSpace

Dim myOlApp         As Outlook.Application

Dim SubFolder       As MAPIFolder

Dim mItem           As MailItem

Dim FSO             As Object

Dim ChosenFolder    As Object

Dim Folders         As New Collection

Dim EntryID         As New Collection

Dim StoreID         As New Collection

Set FSO = CreateObject("Scripting.FileSystemObject")

Set myOlApp = Outlook.Application

Set iNameSpace = myOlApp.GetNamespace("MAPI")

Set ChosenFolder = iNameSpace.PickFolder

If ChosenFolder Is Nothing Then

GoTo ExitSub:

End If

Prompt = "Please enter the path to save all the emails to."

Title = "Folder Specification"

StrSavePath = BrowseForFolder

If StrSavePath = "" Then

GoTo ExitSub:

End If

If Not Right(StrSavePath, 1) = "\" Then

StrSavePath = StrSavePath & "\"

End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count

StrFolder = StripIllegalChar(Folders(i))

n = InStr(3, StrFolder, "\") + 1

StrFolder = Mid(StrFolder, n, 256)

StrFolderPath = StrSavePath & StrFolder & "\"

StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

If Not FSO.FolderExists(StrFolderPath) Then

FSO.CreateFolder (StrFolderPath)

End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))

On Error Resume Next

For j = 1 To SubFolder.Items.Count

Set mItem = SubFolder.Items(j)

StrReceived = ArrangedDate(mItem.ReceivedTime)

StrSubject = mItem.Subject

StrName = StripIllegalChar(StrSubject)

StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"

StrFile = Left(StrFile, 256)

mItem.SaveAs StrFile, 3

Next j

On Error GoTo 0

Next i

ExitSub:

End Sub

Function StripIllegalChar(StrInput)

Dim RegX            As Object

Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"

RegX.IgnoreCase = True

RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:

Set RegX = Nothing

End Function

Function ArrangedDate(StrDateInput)

Dim StrFullDate     As String

Dim StrFullTime     As String

Dim StrAMPM         As String

Dim StrTime         As String

Dim StrYear         As String

Dim StrMonthDay     As String

Dim StrMonth        As String

Dim StrDay          As String

Dim StrDate         As String

Dim StrDateTime     As String

Dim RegX            As Object

Set RegX = CreateObject("vbscript.regexp")

If Not Left(StrDateInput, 2) = "10" And _

Not Left(StrDateInput, 2) = "11" And _

Not Left(StrDateInput, 2) = "12" Then

StrDateInput = "0" & StrDateInput

End If

StrFullDate = Left(StrDateInput, 10)

If Right(StrFullDate, 1) = " " Then

StrFullDate = Left(StrDateInput, 9)

End If

StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")

If Len(StrFullTime) = 10 Then

StrFullTime = "0" & StrFullTime

End If

StrAMPM = Right(StrFullTime, 2)

StrTime = StrAMPM & "-" & Left(StrFullTime, 8)

StrYear = Right(StrFullDate, 4)

StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")

StrMonth = Left(StrMonthDay, 2)

StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)

If Len(StrDay) = 1 Then

StrDay = "0" & StrDay

End If

StrDate = StrYear & "-" & StrMonth & "-" & StrDay

StrDateTime = StrDate & "_" & StrTime

RegX.Pattern = "[\:\/\ ]"

RegX.IgnoreCase = True

RegX.Global = True

ArrangedDate = RegX.Replace(StrDateTime, "-")

ExitFunction:

Set RegX = Nothing

End Function

Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)

Dim SubFolder       As MAPIFolder

Folders.Add Fld.FolderPath

EntryID.Add Fld.EntryID

StoreID.Add Fld.StoreID

For Each SubFolder In Fld.Folders

GetFolder Folders, EntryID, StoreID, SubFolder

Next SubFolder

ExitSub:

Set SubFolder = Nothing

End Sub

Function BrowseForFolder(Optional OpenAt As String) As String

Dim ShellApp As Object

Set ShellApp = CreateObject("Shell.Application"). _

BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next

BrowseForFolder = ShellApp.self.Path

On Error GoTo 0

Select Case Mid(BrowseForFolder, 2, 1)

Case Is = ":"

If Left(BrowseForFolder, 1) = ":" Then

BrowseForFolder = ""

End If

Case Is = "\"

If Not Left(BrowseForFolder, 1) = "\" Then

BrowseForFolder = ""

End If

Case Else

BrowseForFolder = ""

End Select

ExitFunction:

Set ShellApp = Nothing

End Function

我之前在其他论坛发过这个问题，但一直没收到回复，希望在这里能得到大家的指点！

备注：内容来源于stack exchange，提问作者holley