Question

我正在尝试创建一个宏，它会将outlook2010中所选文件夹的所有电子邮件保存到我的桌面，下面的代码会将电子邮件导出到指定位置，但会覆盖任何具有相同主题/时间戳的电子邮件。

请问如何解决这个问题。

Option Explicit
   Dim StrSavePath     As String

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 StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   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

BrowseForFolder StrSavePath

    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 = Format(mItem.ReceivedTime, "YYYYMMDD-hhmmss")
        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


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(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder '  As Folder

Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Desktop\")
StrSavePath = objFolder.self.Path

    On Error Resume Next
    On Error GoTo 0

ExitFunction:
    Set objShell = Nothing

End Function

Answer 1

您可以尝试功能

Function FileExists(file as String) as Boolean
    If Not Dir(file, vbDirectory) = vbNullString Then
        Return True
    Else
        Return False
    End If
End Function

这样您就可以循环并为文件名添加后缀

[your code]

Dim count as Integer = 0
While (FileExists(file))
    count = count + 1
    file = dir & filename & count & extension
End While

一旦找到可用名称

，它就会退出循环

VBA计数器将主题行增加1

1 个答案: