Question

我一直在使用此代码。我只需要从新电子邮件中获取正文并将其放置在文本文件中。我正在按主题过滤并将其移至子文件夹。我没有编写大多数此类代码，并且一直在试图更好地理解它。

我无法确定脚本的哪一部分可以控制。我不需要电子邮件的任何其他部分。

     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") & "\Desktop\Temp\"
        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") _
                                                        & " - " & _
                                                Item.Subject & Ext

                ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

                Item.SaveAs Path & 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 & FileName & Chr(46) & Ext) = True
            FileName = Left(FileName, lngName) & " (" & lngF & ")"
            lngF = lngF + 1
        Loop

        FileNameUnique = FileName & Chr(46) & Ext

        Exit Function
    End Function

Answer 1

此处的快速示例

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:\Temp\Email.txt", ForAppending, True)
        TS.Write (olMsg.Body)
        TS.Close

End Sub

仅将邮件正文输出到txt文件

1 个答案: