Я новичок в Outlook VBA. На онлайн-форумах мне удалось настроить макрос Outlook VBA, который выполняет следующие действия и отлично работает для 8 из 15 электронных писем:
1. Просматривает каждое письмо в папке folder1 (вложенная папка Inbox)
2. Если электронная почта, не применимо в зависимости от темы, перемещена в папку 3 (подпапка «Входящие»)
3. Если применимо к электронной почте, выполняется поиск таблиц в тексте HTML
.
4. Извлекает данные из таблицы, сохраняет в переменных, вставляет в файл Excel
5. Перемещает письмо в папку 2 (подпапка «Входящие»)
Проблема с # 4 выше при поиске таблиц в электронных письмах.
Код не «видит» таблицы, используя следующий объект (oElColl), который позволяет мне получать доступ к таблицам в оставшихся электронных письмах:
With oHTML
.Body.innerHTML = oMail.HTMLBody
Set oElColl = .getElementsByTagName("table")
Произошла ошибка в этих электронных письмах при попытке извлечь значения, используя следующий код:
oElColl(0).rows(0).cells(0).innertext
Позже я заменил oElColl (0) на объект 'tbl', чтобы перебрать все возможные таблицы):
tbl.rows(0).cells(0).inntertext
Для проблемных электронных писем, при отладке это показывает oElColl как «[object]», а «tbl» как Nothing и цикл «Для каждого tbl» ... »выходит без прохождения каких-либо строк между ними.
'tbl' определяется как:
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim oElColl As MSHTML.IHTMLElementCollection
Dim tbl As Object
Для диагностики ошибки я использовал следующее:
Debug.Print oElColl.Length 'result=0 for "bad" emails, so no tables detected
Debug.Print oHTML.Body.innerHTML 'html code different than for "good" emails; no table tags
Debug.Print oMail.BodyFormat 'result=3 (while it's 2 for emails where tables recognized)
Код oHTML.Body.InnerHTML, который выводится на печать, начинается с:
"! - Преобразовано из формата text / rtf -"
В HTML нет тегов "table", а также нет ссылок на intbl, row или cell.
Письма приходят из одного источника и выглядят одинаково при форматировании.
Когда я отвечаю / пересылаю электронное письмо и нажимаю на таблицы в письмах, в левом верхнем углу появляется знак «плюс» со стрелками, как обычно это происходит для таблиц.
Когда я копирую, вставляю содержимое в файл Word, таблица копируется так же, как и для других писем, которые обрабатываются нормально. (Я не хочу использовать документ Word как посредник).
Я попробовал следующее с электронными письмами, чтобы изменить формат RTF на HTML, но затем таблицы были потеряны. Данные просто отображаются в строках; значения, разделенные пробелами.
'If oMail.BodyFormat <> olFormatHTML Then
' oMail.BodyFormat = olFormatHTML
'End If
В настоящее время обходной путь позволяет мне обходить ошибки и вставляет «проверять электронную почту» на наличие пропущенных значений, но, поскольку он делает это примерно для половины электронных писем, я надеюсь, что есть решение для этого, чтобы сделать макрос более полезным.
Примечание о тестовых электронных письмах: Эти электронные письма сохраняются на общем диске (Тип = Элемент Outlook). Около 2 или 3 были сохранены вручную, остальные через более раннюю версию этого же макроса (без кода извлечения данных), который перемещал их из Outlook в папку на общем диске. Я нажал на эти электронные письма, чтобы открыть их, и направил их мне для использования в качестве тестовых электронных писем в моем Outlook. Так как 7 показывает странное поведение, я не думаю, что сохранение 2 или 3 электронных писем вручную является проблемой. Человек использовал настройки по умолчанию при сохранении вручную.
Вот полный код. Я думаю, что проблема в значительной степени описана выше. Разделяя код, так как мне было трудно собрать его из-за нехватки навыков и ресурсов, я видел, как другие онлайн борются с извлечением данных из таблиц Outlook. Это хорошо работает, за исключением проблемы, указанной выше, которая, кажется, связана с определенным форматированием электронной почты:
Option Explicit
Sub Emails_DataToExcel_SaveToDrive_MoveToOutlookFolders()
'This macro looks at each email in Outlook folder1 (subfolder under Inbox)
'If email, not applicable based on subject, it is moved to outlook folder3
'Otherwise, data extracted from tables in the email body and copied to an Excel file which will be updated each time
'Then email saved to specified drive/folder (same folder where Excel file is saved)
'Finally email moved to Outlook folder2 (so folder1 should be blank at the end if all works)
'Edit with your file/folder/path info where needed: "***EDIT..."
'Following checked in Outlook VBA > Tools > References (not sure if all needed):
' Visual Basic for Applications
' Microsoft Outlook xx.x Object Library
' OLE Automation
' Microsoft Office xx.x Object Library
' Microsoft Excel xx.x Object Library
' Microsoft HTML Object library
'Some code borrowed from: https://stackoverflow.com/questions/28479157/macro-to-save-selected-emails-of-outlook-in-windows-folder
Dim myNameSpace As Outlook.NameSpace 'Object '(or Outlook.NameSpace)
Dim myFolder1 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) folder to move FROM
Dim myFolder2 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) Folder to move TO
Dim myFolder3 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) Folder to move emails that aren't applicable
Dim oMail As Object 'not specifying as 'mailobject' becaue threw an error when detected a meeting request email
Dim sFileName As String
Dim dtdate As Date
Dim sDestinationFolder As String
Dim sFullPath As String
Dim sFolder1Name As String 'name of folder to move FROM
Dim sFolder2Name As String 'name of folder to move TO
Dim sFolder3Name As String 'name of folder to move non applicable emails TO
Dim iDupCount As Integer
Dim iNAcount As Integer 'to count non applicable emails
Dim i As Integer
Dim j As Integer
Dim iInitialCount As Integer
Dim iFinalCount As Integer
'to save to Excel
Dim xlApp As Object
Dim xlWb As Workbook
Dim xlWs As Worksheet
Dim sFullPath_Excel As String
Dim sFileName_Excel As String
Dim sSheetName As String
Dim iRowNew As Integer
Dim iRowMax As Integer
Dim bCellNotEmpty As Boolean
Dim sValue1 As String 'extract from body of email
Dim sValue2 As String 'extract from body of email
Dim sValue3 As String 'extract from body of email
Dim sValue4 As String 'extract from body of email
Dim sValue5 As String 'extract from body of email
'***EDIT value for sDestinationFolder. Enter your folder path within the quotes
sDestinationFolder = "[Redacted]" '#Update
'***EDIT value for sFolder1Name. Enter your Outlook folder names.
'those folders MUST be subfolders under the default Inbox folder
'folder to move FROM
sFolder1Name = "foldername1" '#Update folder to save/move FROM
sFolder2Name = "foldername2" '#Update folder to move TO
sFolder3Name = "foldername3" '#Update folder to move non-applicable emails to
'***EDIT value for Excel file and sheet to save tracking info
sFileName_Excel = "file name with required table to update" '#Update Excel file name
sFullPath_Excel = sDestinationFolder & "\" & sFileName_Excel
sSheetName = "sheet name with table" '#Update with Excel sheet name
'-----OPEN EXCEL FILE if not already open
Set xlApp = GetObject(, "Excel.Application") '.Application
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
xlApp.Visible = True
'Added this as Excel file disappeared at times even with .visible above
With xlApp
If .Height < 50 Or .Width < 50 Then
.Height = 400
.Width = 600
.Left = 5
.Top = 50
End If
End With
If IsFileOpen(sFullPath_Excel) Then
MsgBox ("Tracking file is already open by you or another user." & vbNewLine & _
"SAVE & CLOSE following file then rerun macro:" & vbNewLine & vbNewLine & _
sFullPath_Excel)
Exit Sub
End If
Set xlWb = xlApp.Workbooks.Open(sFullPath_Excel)
Set xlWs = xlWb.Worksheets(sSheetName)
'FIND the LAST ROW on EXCEL SHEET to paste data; 'xlup' won't work unless Excel object library selected in Tools>Options
'check the last row in all columns to column "Z" (26) and use max value (to prevent writing over data if values missing in one column)
i = 0
iRowNew = 0
For i = 1 To 26
iRowMax = xlWs.Cells(xlWs.Rows.Count, i).End(xlup).Row + 1
If iRowMax > iRowNew Then iRowNew = iRowMax
Next i
' Debug.Print iRowNew
'-------------------------------------------
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder1 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder1Name)
Set myFolder2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder2Name)
Set myFolder3 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder3Name)
'initialize idupcount (to check if email already saved to shared drive)
iDupCount = 0
iNAcount = 0
iInitialCount = myFolder1.items.Count
If iInitialCount = 0 Then
MsgBox "No emails to process in folder: """ & myFolder1 & """ !"
Exit Sub
End If
'######### Use HTML to get table info ############
'borrowed from: https://www.mrexcel.com/forum/excel-questions/782816-extract-table-outlook-message-excel-using-vba.html
' get html table from email object
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim oElColl As MSHTML.IHTMLElementCollection
Dim tbl As Object
'rest of above code copied within 'For' loop to use during iterations
'##############################################
'For Each oMail In myFolder1.items
'use step-1 or iteration fails half way as emails moved to other folder
For i = myFolder1.items.Count To 1 Step -1
Set oMail = myFolder1.items(i)
'$$$--If email not applicable move to folder3 in Outlook and go to next email
If UCase(oMail.Subject) Like "*REMINDER*" Or _
UCase(oMail.Subject) Like "*ANNOUNCEMENT*" Then
iNAcount = iNAcount + 1
oMail.Move myFolder3
GoTo FoundNAemail
End If
'$$$------
sFileName = oMail.Subject 'Use email subject as file name
ReplaceCharsForFileName sFileName, "()" 'replace characters not allowed in file names
dtdate = oMail.ReceivedTime
sFileName = Format(dtdate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
Format(dtdate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sFileName & ".msg"
sFullPath = sDestinationFolder & "\" & sFileName
If Dir(sFullPath) <> "" Then
iDupCount = iDupCount + 1
End If
If Dir(sFullPath) = "" Then
'Tried code below to change rtf to html, but table formatting was lost; just converted to lines
'If oMail.BodyFormat <> olFormatHTML Then
' oMail.BodyFormat = olFormatHTML
'End If
Debug.Print "emailBodyFormat: " & oMail.BodyFormat
'######### Use HTML to get table info using "table" tag to locate table; skip if tag not found ############
With oHTML
.Body.innerHTML = oMail.HTMLBody
Set oElColl = .getElementsByTagName("table")
Debug.Print oElColl.Length 'gives number of tables; found a "hidden" table
'Debug.Print oHTML.Body.innerHTML 'This will print the html code of entire email to Immediate window
End With
If oElColl Is Nothing Then GoTo NoTableTagsInEmail 'to bypass emails with no HTML "table" tags
'Iterate through table array (table,row,cell(column)); starts at index(0,0,0)
'Since there may be 'hidden' tables, iterating through each table instead of using "oElColl(0)" format for exact table
'Extract relevent info from first tables, when headers match to what's needed
For Each tbl In oElColl
On Error Resume Next
If Trim(UCase(tbl.Rows(0).Cells(0).innerText)) = "header1" Or _
Trim(UCase(tbl.Rows(0).Cells(0).innerText)) = "header1a" Or _
Trim(UCase(tbl.Rows(0).Cells(0).innerText)) = "header1b" Then
sValue1 = tbl.Rows(1).Cells(0).innerText
End If
On Error GoTo 0
On Error Resume Next
If Trim(UCase(tbl.Rows(0).Cells(1).innerText)) = "header2" Then
sValue2 = tbl.Rows(1).Cells(1).innerText
End If
On Error GoTo 0
On Error Resume Next
If Trim(UCase(tbl.Rows(0).Cells(2).innerText)) = "header3" Then
sValue3 = tbl.Rows(1).Cells(2).innerText
End If
On Error GoTo 0
On Error Resume Next
If Trim(UCase(tbl.Rows(0).Cells(3).innerText)) = "header4" Then
sValue4 = tbl.Rows(1).Cells(3).innerText
End If
On Error GoTo 0
'Extract relevent info from 2nd visible table. table/row/cell index starting at zero
'Could be oElColl(1) or oElColl(2), so using 'tbl' object to iterate through each table
On Error Resume Next
If Trim(UCase(tbl.Rows(0).Cells(2).innerText)) = "header5" And _
Trim(UCase(tbl.Rows(1).Cells(0).innerText)) Like "*header6*" Then
sValue5 = tbl.Rows(1).Cells(2).innerText
End If
On Error GoTo 0
Next tbl
'##############################################
NoTableTagsInEmail:
'If values were not found
If Trim(sValue1) = "" Then sValue1 = "check email"
If Trim(sValue2) = "" Then sValue2 = "check email"
If Trim(sValue3) = "" Then sValue3 = "check email"
If Trim(sValue4) = "" Then sValue4 = "check email"
If Trim(sValue5) = "" Then sValue5 = "check email"
'-----################---copy data to Excel file-----------
xlWs.Range("A" & iRowNew) = "No" 'default
xlWs.Range("B" & iRowNew) = oMail.Subject
xlWs.Range("C" & iRowNew) = oMail.ReceivedTime
xlWs.Range("D" & iRowNew) = oMail.SenderName
'Paste values extracted from tables
xlWs.Range("E" & iRowNew) = sValue1
xlWs.Range("G" & iRowNew) = sValue2
xlWs.Range("F" & iRowNew) = sValue3
xlWs.Range("H" & iRowNew) = sValue4
xlWs.Range("I" & iRowNew) = sValue5
iRowNew = iRowNew + 1
'-----###########---end copy data to Excel file------------
'@@@@@ COMMENT code between @@@ when need to debug without the need to move back/delete emails from folders
oMail.SaveAs sFullPath, olMSG 'save to specified path
'IF statement below replaces contacts in "TO" and "CC" with default text...
'...as emails with large # of contacts didn't allow saving via macro
If Err <> 0 Then
oMail.To = "MANY-Removed for processing"
oMail.CC = "MANY-Removed for processing"
oMail.SaveAs sFullPath, olMSG 'save to specified path
End If
DoEvents
oMail.Move myFolder2 'moves processed email to folder2
'@@@@@@@ -----------------------------------@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
DoEvents
End If
Set oElColl = Nothing
sValue1 = ""
sValue2 = ""
sValue3 = ""
sValue4 = ""
sValue5 = ""
FoundNAemail:
Next i
iFinalCount = myFolder1.items.Count
'Inform of number of non-applicable emails
If iNAcount > 0 Then
MsgBox "Check Outlook folder """ & sFolder3Name & """ for " & iNAcount & " emails deemed Non Applicable."
End If
'if all emails moved out of folder1
If iFinalCount = 0 Then
MsgBox iInitialCount - iNAcount & " emails saved to shared drive (" & Left(sFullPath, 10) & "...) and moved to Outlook folder (" & myFolder2 & ")"
End If
If iFinalCount > 0 Then
If iDupCount = iFinalCount Then
MsgBox iFinalCount & " emails could not be saved to shared drive:" & vbNewLine & _
sDestinationFolder & vbNewLine & vbNewLine & _
"These emails already exist in shared drive folder."
ElseIf iDupCount = 0 Then
MsgBox iFinalCount & " emails could not be saved to shared drive:" & sDestinationFolder & vbNewLine & _
vbNewLine & "Please save them manually and move out of Outlook folder."
ElseIf iDupCount < iFinalCount Then
MsgBox iFinalCount & " emails could not be saved to shared drive:" & sDestinationFolder & vbNewLine & _
vbNewLine & "Please save them manually and move out of Outlook folder." & vbNewLine & _
vbNewLine & iDupCount & " of these emails already saved in shared drive folder."
End If
End If
MsgBox "Tracking file updated. Please review, save, and close."
End Sub
Вот две функции, вызываемые в коде. Не актуально, но если кто-то хочет использовать:
Функция # 1 для проверки, если файл уже открыт:
Function IsFileOpen(filename As String)
'Borrowed from: https://support.microsoft.com/en-us/help/291295/macro-code-to-check-whether-a-file-is-already-open
Dim filenum As Integer
Dim errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user. (QL: even if that user is you)
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
MsgBox ("Unidentified error when checking if file open. Error: " & Error)
End Select
End Function
Функция # 2 для замены нежелательных символов из темы для использования в качестве имени файла:
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
'This function is used in the original sub to change characters in the subject which may cause an error when saving file
'To add to list, copy/paste one of the lines to the list...
' enter the character to remove in the first set of quotes
' enter its replacement in the second set of quotes
sName = Replace(sName, "'", "-")
sName = Replace(sName, "*", "-")
sName = Replace(sName, "/", "-")
sName = Replace(sName, "\", "-")
sName = Replace(sName, ":", "-")
sName = Replace(sName, ";", "-")
sName = Replace(sName, "?", "-")
sName = Replace(sName, Chr(34), "-") 'chr(34) is double quotes (")
sName = Replace(sName, "<", "(")
sName = Replace(sName, ">", ")")
sName = Replace(sName, "|", "-")
sName = Replace(sName, "[", "(")
sName = Replace(sName, "]", ")")
sName = Replace(sName, "{", "(")
sName = Replace(sName, "}", ")")
sName = Replace(sName, "@", "(at)")
End Sub