Сохраните выбранные электронные письма Outlook, используя путь UN C, на общий диск в виде MSG-файла.

Question

Я хотел бы найти способ сохранить выбранные электронные письма Outlook, используя путь UN C, на общий диск в виде файла .msg.

У меня есть код, который делает именно то, что я ищу (ниже), однако он использует средство выбора папки, и я просто хотел бы жестко кодировать UNC path вместо

Пример "\\ent.core.company.com\emails\".

Public Sub SaveMessageAsMsg123()       'This works, but with folder picker
'http://www.vbaexpress.com/forum/showthread.php?64358-Saving-Multiple-Selected-Emails-As-MSG-Files-In-Bulk-In-Outlook

    Dim xShell As Object
    Dim xFolder As Object
    Dim strStartingFolder As String
    Dim xFolderItem As Object

    Dim xMail As MailItem
    Dim xObjItem As Object

    Dim xPath As String
    Dim xFileName As String
    Dim xName As String
    Dim xDtDate As Date

    Set xShell = CreateObject("Shell.Application")
''Set xFolder = CreateObject("WScript.Shell").specialfolders(16)
    On Error Resume Next
    ' Bypass error when xFolder is nothing on Cancel
    Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
''    xFolder = "\\ent.core.company.com\emails\"
    'Remove error bypass as soon as the purpose is served
    On Error GoTo 0

    Debug.Print xFolder

    If Not TypeName(xFolder) = "Nothing" Then
        Set xFolderItem = xFolder.Self
        xFileName = xFolderItem.Path
        ' missing path separator
        If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
    Else
        xFileName = ""
        Exit Sub
    End If

    For Each xObjItem In ActiveExplorer.Selection

        If xObjItem.Class = olMail Then

            Set xMail = xObjItem

            xName = CleanFileName(xMail.Subject)
            Debug.Print xName

            xDtDate = xMail.ReceivedTime

            xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
              vbUseSystem) & Format(xDtDate, "-hhnnss", _
              vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"

            xPath = xFileName & xName

            xMail.SaveAs xPath, olMsg
        End If
    Next

End Sub

Public Function CleanFileName(strFileName As String) As String

    ' http://windowssecrets.com/forums/sho...Charaters-(VBA)

    Dim Invalids
    Dim e
    Dim strTemp As String

    Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")

    strTemp = strFileName

    For Each e In Invalids
        strTemp = Replace(strTemp, e, " ")
        'strTemp = Replace(strTemp, e, "")
    Next

    CleanFileName = strTemp

End Function

Answer 1

Я понял это!

Public Sub SaveMessageAsMsg

    Dim xShell As Object
    Dim xFolder As Object
    Dim strStartingFolder As String
    Dim xFolderItem As Object
    Dim strFolderpath As String

    Dim xMail As MailItem
    Dim xObjItem As Object

    Dim xPath As String
    Dim xFileName As String
    Dim xName As String
    Dim xDtDate As Date

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").specialfolders(16)

    ' Instantiate an Outlook Application object.
    Set objOL = Application

    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    ' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = "\\ent.core.medtronic.com\mit-msp01\CVG US Field Inventory\Lookup_Data\TransportationDelayEmails\"

        xFileName = strFolderpath
        ' missing path separator
        If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"

    For Each xObjItem In ActiveExplorer.Selection

        If xObjItem.Class = olMail Then

            Set xMail = xObjItem

            xName = CleanFileName(xMail.Subject)
            Debug.Print xName

            xPath = xFileName & xName

            xMail.SaveAs xPath & ".msg"         ', olMsg       ' & ".msg"
        End If
    Next

End Sub