Как сохранить сообщение Outlook, используя `OpenFileDialog`, чтобы выбрать папку

Question

Я использую приведенный ниже код для сохранения электронной почты в указанной папке c.

По умолчанию он должен сохраняться в папке Specifi c, однако иногда, если я хочу сохранить в других папках, мне нужно ввести местоположение вручную.

Как использовать 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:\GUIC\JV 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

Answer 1

Работа с Shell.Application MSDN для поиска локальной папки

Попробуйте следующий пример

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:\GUIC\JV Approval Backup"
        CreateFolders fPath
    Else
        BrowseForFolder fPath
    End If

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

            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:\Temp\Folders")
    fPath = objFolder.self.Path
    fPath = fPath & "\"

    Debug.Print fPath

    On Error Resume Next
    On Error GoTo 0

ExitFunction:
    Set objShell = Nothing

End Function