使用VBA将Outlook电子邮件中的富文本表复制到Excel？

我正在为我工​​作的公司build立一个自动化stream程。 我已经设立了人力资源系统，发出一个在不久的将来会休假的员工的富文本表格 （只有格式）。

人力资源系统能够存储每个月的时间假期，PTO和病假时间。 我在SQL中编写了一个代码，让系统发出一个月度表，列出下个月有空rest的所有员工。

我正试图采取这些信息，并将其填充到我们的Outlook日历中。 目前，我已经设置了一个Excel表格，在信息被复制并粘贴到表格中后，该表格将填入一个人员日历。

理想情况下，我希望将这些信息自动复制到Excel工作表或设置一个从Outlook中创build约会的系统。 我现在有点难住。

我以前所有的努力都是失败的。 当谈到VBA时，我是一个小菜鸟，所以我能得到的任何帮助将不胜感激。 谢谢。

电子邮件看起来像这样有很多控制（蓝色的行是标题和放置在它下面的行中的信息）：

Answer 1

编辑：添加@PatrickKbuild议的改进，并添加电子表格的图像。

我终于明白了。 我一直在考虑这个问题，我没有意识到我可以将整个电子邮件复制到剪贴板，然后将其粘贴到Excel电子表格中，而不必格式化。 这是我想出来的，看起来工作得很好：

 '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.1 ' ' Date: 8/16/2016 ' ' This routine will search for the system notifier email ' which holds the leave data. Once found, it will call the ' Copy_Paste_Data sub routine which will take the data from ' the selected email and copy it to the clipboard. Once ' copied the subroutine will then paste it into the Excel ' Leave Notifier Table Workbook. It then calls the Add_Time ' subroutine to adjust the start and end time columns of the ' worksheet to allow for a more readable calendar. ' This routine temporarily disables Excel notifications ' Public, passes olItem to Copy_Paste_Data, returns nothing. ' ' Version 1.1: Added exit for loop if statement, to exit ' loop once email has been found (If Found Then Exit For). ' __________________________________________________________ ' Public Sub Get_Data() ' Declare Variables Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.Namespace Dim myInbox As Outlook.MAPIFolder Dim myitems As Outlook.Items Dim myitem As Object Dim Found As Boolean Dim olItem As MailItem Dim objInsp As Outlook.Inspector Dim myDate As Variant Dim DateStr As String Dim oOutlook As Object ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Un-comment the following section to have program check and ' make sure Outlook is open before proceeding. This is not ' necessary for this program to operate effectively: ' ' On Error Resume Next ' Set oOutlook = GetObject(, "Outlook.Application") ' On Error GoTo 0 ' ' If oOutlook Is Nothing Then ' MsgBox "Outlook Mail is not open. Please open Outlook Mail and try again." ' Exit Sub ' End If ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' On error (wrong data type found) it will skip the item and ' continue to look for the email. On Error Resume Next ' Initialize objInsp variable as an inspector item which can be ' used to search for, and point, to items in the outlook folder Set objInsp = Outlook.Application.ActiveInspector ' Create a string item which holds todays date in a specifically formatted manner. DateStr = CStr(DatePart("m", Date)) & "/" & CStr(DatePart("d", Date)) & "/" & CStr(DatePart("yyyy", Date)) ' Initialize variables and select default message folder for search. Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myitems = myInbox.Items ' Set intitial state of Found variable to False Found = False ' For loop to search through all items in the selected mail folder. For Each myitem In myitems ' If the item belongs to outlook mail class continue. ' Else continue looking until no items are present. If myitem.Class = olMail Then ' Once mail item is found compare it's subject to this string. ' If sting matchs hold selected item and set Found variable to true. ' Else continue looking until no items are present. If InStr(1, myitem.Subject, DateStr & " Upcoming Leave Notifier") > 0 Then ' Set the held item equal to MailItem type variable to hold it for later use. ' Takes object being pointed to and saves it for later use. Set olItem = myitem ' Set true "flag" (make Found variable True) Found = True If Found Then Exit For End If End If Next myitem ' Once all items have been searched check if Found "flag" is true ' If true notify end user and procede to copying and pasting data into worksheept. ' If False go to Else. If Found = True Then MsgBox "Data Found." ' If found pass item to Copy_Paste_Data and call sub rountine. Copy_Paste_Data olItem ' Else query end user for date when email was recieved. Else: ' Set point to return to if item was still not found at user provided date. Not_Found: ' Prompt user for date when email was recieved from the system. myDate = InputBox("Email with todays date not found." & Chr(13) & Chr(13) & "Please enter the date that the email was recieved in the field below. The date should be written in the mm/dd/yyyy format." & Chr(13) & Chr(13) & "Note: Do not include leading zeros. Ex. 01/02/2015 should be 1/2/2015" & Chr(13)) ' If the user does not enter a value or presses Cancle then exit routine. If myDate = "" Then Exit Sub ' Repeat search for email with new date value. For Each myitem In myitems If myitem.Class = olMail Then If InStr(1, myitem.Subject, myDate & " Upcoming Leave Notifier") > 0 Then Set olItem = myitem Found = True If Found Then Exit For End If End If Next myitem ' Query again to see if email was found If Found = True Then ' If found pass item to Copy_Paste_Data and call sub rountine. Copy_Paste_Data olItem ' Else, repeat prompt to end user. Else: GoTo Not_Found End If End If ' Once information has been added run add time to index results with start and end times. Call Add_Time End Sub '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/15/2016 ' ' This subroutine takes object passed from Get_Data and ' copies the data from the body of the email. It then pastes ' that data into the active Excel sheet. ' This subroutine temporarily disables Excel Display Alerts ' Private, returns nothing. '____________________________________________________________ ' Private Sub Copy_Paste_Data(olItem) ' Delcare / Initialize variable Dim DataObj As MSForms.DataObject Set DataObj = New MSForms.DataObject ' Copy HTML body of email to data object DataObj.SetText olItem.HTMLBody ' Copy data object to clipboard DataObj.PutInClipboard ' Disable display alerts (eg size doesn't match warning) Application.DisplayAlerts = False ' Paste the contents of the clipboard to the worksheet (dimensions dont have to match exactly) ActiveSheet.Paste Destination:=Worksheets("Leave Table").Range("A3:G300") ' Notify end user that data transfer was successful. MsgBox "Your data has been transfered successfully." ' Re-enable Excel alerts Application.DisplayAlerts = True End Sub '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/15/2016 ' ' This subroutine examines the items in the table and looks ' for days where multiple employees have requested time off ' On those days it will increment each employees scheduled ' start and end time by 30 minutes to provide a cleaner ' appointment view on the calendar. This allows the names to ' appear as though they are listed on the days of the week ' they are added to. For each new date, the routine will ' begin the appointment start times at 8:00 AM and add 30 ' minuted for every subsequent employee. ' Private, returns nothing. '____________________________________________________________ ' Private Sub Add_Time() ' Initialize variables Dim time As Date Dim HoldDate As Date Dim PrevRowDate As Date Dim LastDate As Date Dim LastName As String Dim NextRowDate As Date ' Set Work sheet to be edited Dim wsSrc As Worksheet Set wsSrc = ActiveWorkbook.Sheets("Leave Table") ' Set initial values HoldDate = DateValue(wsSrc.Cells(4, 3)) PrevRowDate = DateValue(wsSrc.Cells(4, 3)) time = TimeValue("08:00:00") ' Set values for first row (after header) of the table (row 3) wsSrc.Cells(4, 8).Value = TimeValue("08:00:00") wsSrc.Cells(4, 9).Value = TimeValue("08:30:00") r = 4 ' Loop to find the end of the list Do Until Trim(wsSrc.Cells(r, 1).Value) = "" r = r + 1 Loop ' Set the second to last item as the ending point. ' We do not want to use the last row because it would throw a data type error when the end is reached. r = r - 1 LastName = wsSrc.Cells(r, 1).Value LastDate = DateValue(wsSrc.Cells(r, 3)) ' Begin at row 4 (Rows 1 & 2 are headers. Beginning at row 3 would include invalid data type from row 2) r = 5 ' Repeat this loop until the second to last row is reached. Do Until wsSrc.Cells(r, 1).Value = wsSrc.Cells(r, 1).Value And DateValue(wsSrc.Cells(r, 3)) = LastDate ' Hold the date in the current row HoldDate = DateValue(wsSrc.Cells(r, 3)) ' Set the next date equal to the date being held. ' This allows for the next loops conditions to be met for entry into the do/while loop. NextRowDate = DateValue(wsSrc.Cells(r, 3)) ' Get the date from the previous row and hold it for comparison to the held date. ' This is done to endure the add time loop is not entered prematurely. r = r - 1 PrevRowDate = DateValue(wsSrc.Cells(r, 3)) r = r + 1 ' Add time loop to increment time in calendar by 30 minutes ' while HoldDate does not equal PrevRowDate or NextRowDate. ' Note: Previous row date holds the same value it recieved from outside of the loop. ' Thus, the condition relies entirely on the NextRowDate. Do Until HoldDate <> PrevRowDate Or HoldDate <> NextRowDate ' Get the date of the next row. r = r + 1 NextRowDate = DateValue(wsSrc.Cells(r, 3)) r = r - 1 ' Plase the current time value + 30 min into the Start time column of this row wsSrc.Cells(r, 8).Value = CDate(time) + 1 / 48 ' Add 30 min to the time value time = CDate(time) + 1 / 48 ' Plase the current time value + 30 min into the End time column of this row wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48 ' Increment row r = r + 1 Loop ' Reset time to 8:00 AM time = TimeValue("08:00:00") ' Place 8:00 Am in the Start time column of this row wsSrc.Cells(r, 8).Value = CDate(time) ' Place 8:30 Am in the End time column of this row wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48 ' Increment row r = r + 1 Loop ' Add time values for the last date in the table. ' Begin at 7:30 AM for simplicity time = TimeValue("07:30:00") ' Repeat loop to add start and end times for each person on the last day of the ' table, adding 30 minutes each time. Do Until Trim(wsSrc.Cells(r, 1).Value) = "" wsSrc.Cells(r, 8).Value = CDate(time) + 1 / 48 time = CDate(time) + 1 / 48 wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48 r = r + 1 Loop End Sub 

电子表格将会显示出今天的通知电子邮件，然后将其复制并粘贴到电子表格中，然后使用以下程序将其直接上传到全局日历中：

 '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/16/2016 ' ' This is the main program which will call the other subs. ' The Create_Outlook sub calls Clean_Leave_Calendar sub to ' delete all emails from the leave calendar before attempting ' to add new items to the calendar. Once the calendar has ' been cleaned and the times have been added, the program ' creates new appointments items in the predetermined outlook ' folder "oFolder". Once the appointment items have been ' created the program notifies the end user that the process ' ran successfully and runs Close_Workbook subroutine to ' close workbook without saving. '____________________________________________________________ ' Public Sub Populate_Calendar() ' Initialize variables Dim oApp As Object Dim oNameSpace As Namespace Dim oFolder As Object Dim wsSrc As Worksheet Set wsSrc = Sheets("Leave Table") ' Call subroutines Call Clean_Leave_Calendar ' Start looping at row 3 (first two rows are for readability) r = 4 ' Do/while set condition Do Until Trim(wsSrc.Cells(r, 1).Value) = "" ' Create the Outlook session Set oApp = New Outlook.Application ' Set the namespace Set oNameSpace = oApp.GetNamespace("MAPI") ' Set the folder the appointment will be created in. Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000").Items.Add(olAppointmentItem) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Use the following code in Outlook to find the Folder ID #: ' Note: WITH THE CALENDAR YOU WANT TO CREATE APPOINTMENTS IN ' SELECTED, press F11 to bring up Outlook macros and run the ' code under "ThisOutlookSession" ' ' Private Sub GetOutlookFolderID() ' 'Determines the Folder ID of Folder ' Dim olfolder As Outlook.MAPIFolder ' Dim olapp As Outlook.Application ' Set olapp = CreateObject("Outlook.Application") ' Set olfolder = olapp.GetNamespace("MAPI").PickFolder ' olfolder.Display ' MsgBox (olfolder.EntryID) ' Set olfolder = Nothing ' Set olapp = Nothing ' End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Set with block for the appointment configuration loop With oFolder ' Set Subject line of event .Subject = wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value ' Set start time .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value ' Set end time .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value ' Turn reminders off .ReminderSet = False ' Set busy status to free .BusyStatus = 0 ' Have the body of the event read as the decription from the leave form in Viewpoint .Body = wsSrc.Cells(r, 4).Value ' Save event in owners calendar .Save ' End with block End With ' Move to next row r = r + 1 ' Repeat do/while loop until condition is no longer valid Loop ' Clean house Set oApp = Nothing Set oNameSpace = Nothing Set oFolder = Nothing Set wsSrc = Nothing MsgBox "Data was successfully added to the Outlook Leave Calendar." & Chr(13) & Chr(13) & "Excel workbook will now close." Call CloseWorkbook End Sub '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/15/2016 ' ' This sub will close the current workbook without saving. ' Before closing it will check to make sure there are no ' other workbooks are open and if there are none, it will ' close the Excel application as well. This sub will also ' temporarily disable displayed "Would you like to save your ' workbook" notification. ' Private, returns nothing. '____________________________________________________________ ' Private Sub CloseWorkbook() Application.DisplayAlerts = False If Workbooks.Count < 2 Then Application.Quit Else ThisWorkbook.Close End If End Sub '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/15/2016 ' ' This sub will call the Clean_Leave_Calendar subroutine ' 5 times. The Clean_Leave_Calendar subroutine will look for ' appointment items in the predefined outlook folder. Once ' an appointment item is identified the program will ' perminately delete the item to avoid scheduling conflicts ' with new items to be added. The deletion loop runs 10 ' times to ensure all items are successfully removed. ' Public, returns nothing '____________________________________________________________ ' Public Sub Power_Wash() Dim i As Integer i = 0 Do Until i = 5 Call Clean_Leave_Calendar i = i + 1 Loop End Sub '____________________________________________________________ ' ' Author: Joshua Bryant ' ' Version 1.0 ' ' Date: 8/15/2016 ' ' This sub will look for appointment items in the predefined ' outlook folder. Once an appointment item is identified the ' program will perminately delete the item to avoid schedule ' conflicts with new items to be added. The deletion loop ' runs 10 times to ensure all items are successfully removed ' Private, returns nothing '____________________________________________________________ ' Private Sub Clean_Leave_Calendar() ' Initialize variables Dim oApp As Outlook.Application Dim oNameSpace As Outlook.Namespace Dim oApptItem As Outlook.AppointmentItem Dim oFolder As Outlook.MAPIFolder Dim oMeetingoApptItem As Outlook.MeetingItem Dim oObject As Object Dim i As Integer ' Set error states On Error Resume Next ' Check if Outlook is running Set oApp = GetObject("Outlook.Application") If Err <> 0 Then 'If Outlook is not running, start it. Set oApp = CreateObject("Outlook.Application") End If ' Set the folder the appointments can be found in. See main function "Create Outlook" for more details. Set oApp = New Outlook.Application Set oNameSpace = oApp.GetNamespace("MAPI") Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000") ' Set initial value of i to 0 i = 0 ' Repeat deleting function 10 times to make sure all apointments have been cleared from the folder. Do Until i = 10 CheckAppointment = False ' For each of the "objects" appointments and other in the folder specified above repeat the loop. ' Beacause not all of the objects are appointments it sometimes ends to early, ' which is why it runs 10 times. (Easier than coding a more stringent code, and really not the ' resource demanding). For Each oObject In oFolder.Items ' Compare each object to appoint class and delete objects where match is found. If oObject.Class = olAppointment Then Set oApptItem = oObject oApptItem.Delete End If ' Repeat for each object / item. Next oObject ' Rinse and repeat. i = i + 1 Loop ' Clear variables Set oApp = Nothing Set oNameSpace = Nothing Set oApptItem = Nothing Set oFolder = Nothing Set oObject = Nothing End Sub 

子例程清除共享日历。 然后主例程上传新的date。 最后，一个子程序closures工作簿。

如果有人有任何清理的build议，请让我知道。

谢谢！

此外， 这里是我正在使用的Excel工作表的图像。