Com exportar correus electrònics d'Outlook a Excel automàticament?

Normalment, podeu exportar els missatges de correu electrònic d'Outlook a Excel amb la funció d'importació / exportació. Però, alguna vegada has intentat exportar automàticament els correus electrònics a l'arxiu d'Excel quan arribin nous missatges? En aquest article, parlaré sobre com exportar automàticament la informació dels nous missatges entrants a Excel.

Exportació automàtica d'informació de correu electrònic des de Outlook a Excel amb codi VBA

Exportació automàtica d'informació de correu electrònic des de Outlook a Excel amb codi VBA

Per exportar automàticament els nous correus electrònics d'arribada a un llibre d'Excel, apliqueu el codi VBA següent:

1. En primer lloc, haureu de crear un quadern de treball amb la informació de capçalera a continuació, com es mostra a la següent captura de pantalla, de manera que aquesta informació dels missatges s'exportarà a aquest fitxer Excel.

2. A continuació, vagi a Outlook i mantingueu premut el ALT + F11 claus per obrir el Microsoft Visual Basic per a aplicacions finestra.

3. Al Microsoft Visual Basic per a aplicacions finestra, feu doble clic ThisOutlookSession des Project1 (VbaProject.OTM) panell per obrir el mode i, a continuació, copieu i enganxeu el següent codi al mòdul en blanc.

Codi VBA: informació de correu electrònic d'exportació automàtica del fitxer Outlook a Excel:

Public WithEvents GMailItems As Outlook.Items
Private Sub Application_Startup()
    Set GMailItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub GMailItems_ItemAdd(ByVal Item As Object)
    Dim xMailItem As Outlook.MailItem
    Dim xExcelFile As String
    Dim xExcelApp As Excel.Application
    Dim xWb As Excel.Workbook
    Dim xWs As Excel.Worksheet
    Dim xNextEmptyRow As Integer
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xMailItem = Item
    xExcelFile = "C:\Users\DT168\Desktop\split document\kto-data.xlsx"
    If IsWorkBookOpen(xExcelFile) = True Then
        Set xExcelApp = GetObject(, "Excel.Application")
        Set xWb = GetObject(xExcelFile)
        If Not xWb Is Nothing Then xWb.Close True
    Else
        Set xExcelApp = New Excel.Application
    End If
    Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
    Set xWs = xWb.Sheets(1)
    xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
    With xWs
        .Cells(xNextEmptyRow, 1) = xNextEmptyRow - 1
        .Cells(xNextEmptyRow, 2) = xMailItem.SenderName
        .Cells(xNextEmptyRow, 3) = xMailItem.SenderEmailAddress
        .Cells(xNextEmptyRow, 4) = xMailItem.Subject
        .Cells(xNextEmptyRow, 5) = xMailItem.ReceivedTime
    End With
    xWs.Columns("A:E").AutoFit
    xWb.Save
End Sub
Function IsWorkBookOpen(FileName As String)
    Dim xFreeFile As Long, xErrNo As Long
    On Error Resume Next
    xFreeFile = FreeFile()
    Open FileName For Input Lock Read As #xFreeFile
    Close xFreeFile
    xErrNo = Err
    On Error GoTo 0
    Select Case xErrNo
        Case 0: IsWorkBookOpen = False
        Case 70: IsWorkBookOpen = True
        Case Else: Error xErrNo
    End Select
End Function

Nota: En el codi anterior, C: \ Users \ DT168 \ Desktop \ split document \ kto-data.xlsx és la ruta del fitxer d'Excel i el nom d'Excel que voleu localitzar la informació exportada, canvieu-la a la vostra necessitat.

4. Encara en el Microsoft Visual Basic per a aplicacions finestra, feu clic a instruments > referències per anar a la Referències: Project1 quadre de diàleg i verificació Biblioteca d'objectes de Microsoft Excel opció de la Referències disponibles quadre de llista, veure captura de pantalla:

5. A continuació, feu clic a OK botó per tancar el diàleg i, a continuació, deseu i tanqueu la finestra del codi.

6. Ara, hauríeu de reiniciar l'Outlook perquè aquest codi tingui efecte. A partir d'ara, si hi ha correus electrònics nous que arriben, s'exportaran automàticament al llibre de treball específic, vegeu la captura de pantalla:

Kutools per Outlook

Més de 100 Advanced Functions for Outlook 2010, 2013, 2016, 2019 i 365

Més funcions | Descàrrega gratuita | Només $ 39.00 per centenars de funcions