Реализация макроса Outlook в Excel

Question

У меня есть следующий макрос в Outlook, и я хотел бы использовать его из Excel, как я могу переписать его, чтобы он работал в Excel без включенного макроса Outlook?

Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet

Public Sub ExportAllFlaggedEmailsToExcel()

Dim objOutlookFile As Outlook.Folder
Dim objFolder As Outlook.Folder
Dim objNameSpace As NameSpace
Dim mailboxowner As Outlook.Recipient
Dim Shared_email_address As Folder
Dim outlookAPP As Outlook.Application

Set outlookAPP = Outlook.Application
Set objOutlookFile = Outlook.Application.Session.PickFolder
Set objNameSpace = Application.GetNamespace("MAPI")

'If Not (objOutlookFile Is Nothing) Then
   'Create a new Excel file
   Set objExcelApp = CreateObject("Excel.Application")
   Set objExcelWorkbook = objExcelApp.Workbooks.Add
   Set objExcelWorksheet = objExcelWorkbook.Sheets("sheet1")
   objExcelApp.Visible = True

    'Name_of_the_excel_file_created_by_the_vba = ActiveWorkbook.Name


    'Name_of_the_excel_file_created_by_the_vba.Select
   With objExcelWorksheet
       .Cells(1, 1) = "Subject"
       .Cells(1, 1).Font.Bold = True
       .Cells(1, 2) = "Email was sent On"
       .Cells(1, 2).Font.Bold = True
       .Cells(1, 3) = "From"
       .Cells(1, 3).Font.Bold = True
       .Cells(1, 4) = "To"
       .Cells(1, 4).Font.Bold = True
       .Cells(1, 5) = "Categroy"
       .Cells(1, 5).Font.Bold = True
  End With

  For Each objFolder In objOutlookFile.Folders
      If objFolder.DefaultItemType = olMailItem Then
         Call ProcessMailFolders(objFolder)
      End If
  Next

  objExcelWorksheet.Columns("A:F").AutoFit

  MsgBox "Completed!", vbInformation + vbOKOnly, "Export Emails"
'End If
End Sub

Public Sub ProcessMailFolders(ByVal objCurrentFolder As Outlook.Folder)
Dim i As Long
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem
Dim nLastRow As Integer
Dim objSubfolder As Outlook.Folder
'***********************
'Outlook to export categorised emails to excel
 '***********************
 amount_of_emails = objCurrentFolder.Items.Count
 For i = 1 To objCurrentFolder.Items.Count
    If objCurrentFolder.Items(i).Class = olMail Then
       'Export the information of each flagged email to Excel
       Set objMail = objCurrentFolder.Items(i)
       On Error Resume Next
       If objMail.Categories = "Category_Name" Then
          Set objFlaggedMail = objMail

          With objExcelWorksheet
               nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
               .Range("A" & nLastRow) = objFlaggedMail.Subject
               .Range("B" & nLastRow) = objFlaggedMail.SentOn
               '.Range("C" & nLastRow) = objFlaggedMail.ReceivedTime
               .Range("C" & nLastRow) = objFlaggedMail.SenderName
               .Range("D" & nLastRow) = objFlaggedMail.To
               .Range("E" & nLastRow) = "Category_Name"

         End With
      End If
    End If
Next i

If objCurrentFolder.Folders.Count > 0 Then
   For Each objSubfolder In objCurrentFolder.Folders
       Call ProcessMailFolders(objSubfolder)
   Next
End If
end sub

Я знаю, что не поддерживается вызов функции / макроса outlook из Excel, поэтому я хотел бы реализовать это на уровне Excel, как я могу его запустить?

Answer 1

Посмотрите, можете ли вы изменить это, чтобы сделать то, что вы хотите (запустить из Excel).

Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages

Sub Download_Outlook_Mail_To_Excel()
    Dim olApp As Object
    Dim olFolder As Object
    Dim olNS As Object
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim NextRow As Long
    Dim i As Long
    Dim olItem As Object
    Set xlBook = Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err() <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    With xlSheet
        .Cells(1, 1) = "Sender"
        .Cells(1, 2) = "Subject"
        .Cells(1, 3) = "Date"
        .Cells(1, 4) = "Size"
        .Cells(1, 5) = "EmailID"
        .Cells(1, 6) = "Body"
        CreateFolders fPath
        Set olNS = olApp.GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        For Each olItem In olFolder.Items
            NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            If olItem.Class = 43 Then
                .Cells(NextRow, 1) = olItem.Sender
                .Cells(NextRow, 2) = olItem.Subject
                .Cells(NextRow, 3) = olItem.SentOn
                '.Cells(NextRow, 4) =
                .Cells(NextRow, 5) = SaveMessage(olItem)
                '.Cells(NextRow, 6) = olItem.Body 'Are you sure?
            End If
        Next olItem
    End With
    MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
    Set olApp = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub

Function SaveMessage(olItem As Object) As String
    Dim Fname As String
    Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
    Fname = Replace(Fname, Chr(58) & Chr(41), "")
    Fname = Replace(Fname, Chr(58) & Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")
    SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
    Exit Function
End Function

Private Function SaveUnique(oItem As Object,
                            strPath As String,
                            strFileName As String) As String
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
    SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Sub CreateFolders(strPath As String)
    Dim strTempPath As String
    Dim iPath As Long
    Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For iPath = 1 To UBound(vPath)
        strPath = strPath & vPath(iPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next iPath
End Sub

Private Function FolderExists(ByVal PathName As String) As Boolean
    Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
End Function

Private Function FileExists(filespec) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function