如何使用“ OpenFileDialog”选择文件夹保存Outlook消息

Posted 2021-04-13

我正在使用以下代码将电子邮件保存到特定文件夹中。

默认情况下，它应该保存在特定文件夹中，但是有时如果我想保存在其他文件夹中，则需要手动输入位置。

如何使用OpenFileDialog选择文件夹。

Option Explicit

Sub SaveMessage()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
    Dim fname As String
Dim fPath As String
Dim JVvalue As Variant

fPath = "C:GUICJV Approval Backup"


    CreateFolders fPath



    If olItem.Sender Like "*@gmayor.com" & olItem.Subject Like "*RE" Then    'Your domain

            fname = JVvalue & "  " & Chr(32) & olItem.SenderName & "   " & Format(olItem.SentOn, "mmmm" & "   " & "YYYY-MM-DD") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & "    " & "     " & Chr(32) & olItem.Subject
    Else
        fname = JVvalue & "   " & Chr(32) & olItem.SenderName & "   " & Format(olItem.ReceivedTime, "mmmm" & "   " & "YYYY-MM-DD") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & "    " & "    " & Chr(32) & olItem.Subject
        End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, fPath, fname
lbl_Exit:
    Exit Sub
End Sub**

Private Function CreateFolders(strPath As String)
    Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "")
    strPath = vPath(0) & ""
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & ""
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
    Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

答案

尝试以下操作

Option Explicit
Dim fPath As String
Sub SaveMessage()
    Dim olMsg As MailItem

    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim JVvalue As Variant

    Dim Result As Integer
    Result = MsgBox("Save it to default folder?", vbQuestion + vbYesNo)

    If Result = vbYes Then
        fPath = "C:GUICJV Approval Backup"
        CreateFolders fPath
    Else
        BrowseForFolder fPath
    End If

    If olItem.Sender Like "*gmayor.com" & olItem.Subject Like "*RE" Then    'Your domain

            fname = JVvalue & "  " & Chr(32) & _
            olItem.SenderName & "   " & _
            Format(olItem.SentOn, "mmmm" & "   " _
            & "YYYY-MM-DD") & Chr(32) & _
            Format(olItem.SentOn, "HH.MM") & "    " & _
            "     " & Chr(32) & olItem.Subject
    Else
        fname = JVvalue & "   " & Chr(32) & olItem.SenderName & _
        "   " & Format(olItem.ReceivedTime, "mmmm" & _
        "   " & "YYYY-MM-DD") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & "    " & _
        "    " & Chr(32) & olItem.Subject
    End If

    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, fPath, fname

lbl_Exit:
    Exit Sub

End Sub

Private Function CreateFolders(strPath As String)
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant

    vPath = Split(strPath, "")
    strPath = vPath(0) & ""

    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & ""
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath

lbl_Exit:
    Exit Function

End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
    Dim lngF As Long
    Dim lngName As Long

    lngF = 1
    lngName = Len(strFileName)

    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop

    oItem.SaveAs strPath & strFileName & ".msg"

    Debug.Print strPath & strFileName & ".msg"

lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
    Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If

lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If

lbl_Exit:
    Exit Function

End Function

Function BrowseForFolder(fPath 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 & "C:TempFolders")
    fPath = objFolder.self.Path
    fPath = fPath & ""

    Debug.Print fPath

    On Error Resume Next
    On Error GoTo 0

ExitFunction:
    Set objShell = Nothing

End Function