Автоматический экспорт электронной почты из Outlook в Excel

Question

Я нашел в интернете и немного изменил кусок кода:

Public WithEvents objMails As Outlook.Items 

Private Sub Application_Startup() 
Const pierwszy = "pierwszy@gmail.com" 
Const drugi = "drugi@gmail.com" 
Dim OutAcc As Account 
Debug.Print "Startup" 
    For Each OutAcc In Outlook.Application.Session.Accounts 
        If (OutAcc.DisplayName = pierwszy) Then 
            Set objMails = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items 
            Exit For 
        End If 
        If (OutAcc.DisplayName = drugi) Then 
            Set objMails = OutAcc.DeliveryStore.GetDefaultFolder(olFolderInbox).Items 
            Exit For 
        End If 
    Next 
End Sub 


Private Sub objMails_ItemAdd(ByVal Item As Object) 
    Dim objMail As Outlook.MailItem 
    Dim strExcelFile As String 
    Dim objExcelApp As Excel.Application 
    Dim objExcelWorkBook As Excel.Workbook 
    Dim objExcelWorkSheet As Excel.Worksheet 
    Dim nNextEmptyRow As Integer 
    Dim strColumnB As String 
    Dim strColumnC As String 
    Dim strColumnD As String 
    Dim strColumnE As String 

    If Item.Class = olMail Then 
       Set objMail = Item 
    End If 

    'Specify the Excel file which you want to auto export the email list 
    'You can change it as per your case 
    strExcelFile = "C:\Users\karol\Documents\test.xlsx" 

    'Get Access to the Excel file 
    On Error Resume Next 
    Set objExcelApp = GetObject(, "Excel.Application") 
    If Error <> 0 Then 
       Set objExcelApp = CreateObject("Excel.Application") 
    End If 
    Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile) 
    Set objExcelWorkSheet = objExcelWorkBook.Sheets("Arkusz1") 

    'Get the next empty row in the Excel worksheet 
    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1 

    'Specify the corresponding values in the different columns 
    strColumnB = objMail.SenderName 
    strColumnC = objMail.SenderEmailAddress 
    strColumnD = objMail.Subject 
    strColumnE = objMail.ReceivedTime 
    strColumnF = objMail.Body 
    strColumnG = objMail.To 

    'Add the vaules into the columns 
    objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1 
    objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB 
    objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC 
    objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD 
    objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE 
    objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF 
    objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG 

    'Fit the columns from A to E 
    objExcelWorkSheet.Columns("A:G").AutoFit 

    'Save the changes and close the Excel file 
    objExcelWorkBook.Close SaveChanges:=True 

End Sub

Этот код работает нормально, когда в приложении Outlook я захожу в один почтовый ящик (одно электронное письмо),Я столкнулся с проблемой, когда пытался автоматически экспортировать электронные письма из двух почтовых ящиков (две учетные записи с разными адресами электронной почты, на которых я вошел в приложение Outlook) - посмотрите на картинку:

https://ibb.co/mXWZJsw

Я попытался решить эту проблему с помощью операторов If в процедуре Application_Startup () (как видно из кода выше).Этот подход, к сожалению, не работает.Я также заметил, что, например, когда первое электронное письмо поступает на учетную запись «pierwszy@gmail.com», то, пока приложение не будет закрыто, электронные письма будут экспортироваться в Excel только из этой учетной записи «pierwszy@gmail.com», а неэкспортировано из аккаунта "drugi@gmail.com".Однако когда первое электронное письмо поступит на учетную запись «drugi@gmail.com», электронные письма будут экспортироваться из второго электронного письма «drugi@gmail.com» до тех пор, пока приложение не будет закрыто.

Answer 1

Позвольте мне предварить это словами: не знаю, как работают правила для нескольких учетных записей.Возможно, вам придется создать правило для ОБА учетных записей, но они могут ссылаться на один и тот же сценарий.

Я обновил ваш код, чтобы он стал общедоступным Sub против Private Sub, и поместил его в модуль, чтобына него может ссылаться механизм правил.

Теперь, когда у нас есть код (скрипты, запускаемые механизмом правил, обычно по своей сути передают электронную почту).как MailItem для подпрограммы, и ByVal вызывал проблемы с распознаванием сценария как запускаемого из MailItem, поэтому я обновил его до Item as MailItem).

Затем мы создадим новое правило, используя механизм правил.Если вы видите этот упрощенный интерфейс, нажмите на Дополнительные параметры.Это позволит нам применять правила ко всем электронным письмам.В окне дополнительных параметров не устанавливайте флажок для Which conditions do you want to check?, просто нажмите кнопку Далее.Он подтвердит, что вы хотите добавить это правило для ВСЕХ ЭЛЕКТРОННЫХ ПОЧТ, которые мы делаем.

После выбора run a script мы можем нажать a script, чтобы указать, какой скрипт мы хотим запустить.Я установил его в сценарий exportToExcel в модуле (проект) 1

Нажмите Готово и протестируйте его.

Sub exportToExcel(item As MailItem)
    Dim objMail As Outlook.MailItem
    Dim strExcelFile As String
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkBook As Excel.Workbook
    Dim objExcelWorkSheet As Excel.Worksheet
    Dim nNextEmptyRow As Integer
    Dim strColumnB As String
    Dim strColumnC As String
    Dim strColumnD As String
    Dim strColumnE As String

    If item.Class = olMail Then
       Set objMail = item
    End If

    'Specify the Excel file which you want to auto export the email list
    'You can change it as per your case
    strExcelFile = "C:\Users\karol\Documents\test.xlsx"

    'Get Access to the Excel file
    On Error Resume Next
    Set objExcelApp = GetObject(, "Excel.Application")
    If Error <> 0 Then
       Set objExcelApp = CreateObject("Excel.Application")
    End If
    Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
    Set objExcelWorkSheet = objExcelWorkBook.Sheets("Arkusz1")

    'Get the next empty row in the Excel worksheet
    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.count).End(xlUp).Row + 1

    'Specify the corresponding values in the different columns
    strColumnB = objMail.SenderName
    strColumnC = objMail.SenderEmailAddress
    strColumnD = objMail.Subject
    strColumnE = objMail.ReceivedTime
    strColumnF = objMail.Body
    strColumnG = objMail.To

    'Add the vaules into the columns
    objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
    objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
    objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
    objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
    objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
    objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
    objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG

    'Fit the columns from A to E
    objExcelWorkSheet.Columns("A:G").AutoFit

    'Save the changes and close the Excel file
    objExcelWorkBook.Close SaveChanges:=True

End Sub