Блог

Я работал с этим кодом. Мне нужно взять только тело из нового электронного письма и поместить его в текстовый файл. Я фильтрую по теме и перемещаю ее во вложенную папку. Я не писал большую часть этого кода и пытался лучше понять его.

Я не могу определить, какая часть скрипта управляет этим. Мне не нужна никакая другая часть электронного письма.

      Option Explicit
    Private WithEvents Items As Outlook.Items
    Private Sub Application_Startup()
        Dim olNs As Outlook.NameSpace
        Dim Inbox  As Outlook.MAPIFolder

        Set olNs = Application.GetNamespace("MAPI")
        Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
        Set Items = Inbox.Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
        If TypeOf Item Is Outlook.MailItem Then
            SaveMailAsFile Item ' call sub
        End If
    End Sub
    Public Sub SaveMailAsFile(ByVal Item As Object)
        Dim olNs As Outlook.NameSpace
        Dim Inbox As Outlook.MAPIFolder
        Dim SubFolder As Outlook.MAPIFolder
        Dim Items As Outlook.Items
        Dim ItemSubject As String
        Dim NewName As String
        Dim RevdDate As Date
        Dim Path As String
        Dim Ext As String
        Dim i As Long

        Set olNs = Application.GetNamespace("MAPI")
        Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
        Set Items = Inbox.Items.Restrict("[Subject] = 'Auto~! Keep ad the same'")

        Path = Environ("USERPROFILE") amp; "DesktopTemp"
        ItemSubject = Item.Subject
        RevdDate = Item.ReceivedTime
        Ext = "txt"

        For i = Items.Count To 1 Step -1
            Set Item = Items.Item(i)

            DoEvents

            If Item.Class = olMail Then
                Debug.Print Item.Subject ' Immediate Window
                Set SubFolder = Inbox.Folders("SSX") ' <--- Update Fldr Name

                ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
                                                        amp; " - " amp; _
                                                Item.Subject amp; Ext

                ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

                Item.SaveAs Path amp; ItemSubject, olTXT
                Item.Move SubFolder
            End If
        Next

        Set olNs = Nothing
        Set Inbox = Nothing
        Set SubFolder = Nothing
        Set Items = Nothing

    End Sub


    '// Check if the file exists
    Private Function FileExists(FullName As String) As Boolean
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")

        If fso.FileExists(FullName) Then
            FileExists = True
        Else
            FileExists = False
        End If

        Exit Function
    End Function

    '// If the same file name exist then add (1)
    Private Function FileNameUnique(Path As String, _
                                   FileName As String, _
                                   Ext As String) As String
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(FileName) - (Len(Ext)   1)
        FileName = Left(FileName, lngName)

        Do While FileExists(Path amp; FileName amp; Chr(46) amp; Ext) = True
            FileName = Left(FileName, lngName) amp; " (" amp; lngF amp; ")"
            lngF = lngF   1
        Loop

        FileNameUnique = FileName amp; Chr(46) amp; Ext

        Exit Function
    End Function
  

Краткий пример здесь

 Option Explicit
Private Sub Example()
    Dim FSO As New FileSystemObject
    Dim TS As TextStream
    Dim olMsg As Outlook.MailItem

    Set olMsg = ActiveExplorer.selection.Item(1)
    Set TS = FSO.OpenTextFile("C:TempEmail.txt", ForAppending, True)
        TS.Write (olMsg.Body)
        TS.Close

End Sub