我通常会在电子邮件中收到员工通知，我需要从所有这些电子邮件中编辑excel表，以了解员工从上一行到当前行的状态变化。
亲爱的，
以下员工的状态变化按以下详细说明进行：
新状态
改变工作
生效日期
01-FEB-2015
员工姓名
Ricky ponting员工代码
4982
指定
采购主管（借调）
工作组
1A
系
采购＆amp;供应链
单元
技术采购
司
金融
位置
伊斯兰堡
报告热线
Micheal king先生
注：Ricky Ponting之前曾担任组织沟通部门的关税实施支持官，并向Robin Sing先生汇报。
我需要有关导出HTML表格数据的工作代码。最后注意：全行，这样我就可以拥有2000个员工的excel文件，他们的状态已被更改，我可以轻松地从他们报告的前一行中进行排序新线路和我可以在以后阶段与新线路进行任何访问权限重新授权练习。
目前我正在使用以下代码，这些代码可以正常使用表格提取，但注意：不会使用以下代码根据以下网址获取行
https://techniclee.wordpress.com/2011/10/29/exporting-outlook-messages-to-excel/
Const MACRO_NAME = "Export Messages to Excel (Rev Sajjad)"
Private Sub ExportMessagesToExcel()
Dim olkFld As Outlook.MAPIFolder, _
olkMsg As Outlook.MailItem, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
arrCel As Variant, _
varCel As Variant, _
lngRow As Long, _
intPtr As Integer, _
intVer As Integer
Set olkFld = Session.PickFolder
If TypeName(olkFld) = "Nothing" Then
MsgBox "You did not select a folder. Operation cancelled.", vbCritical + vbOKOnly, MACRO_NAME
Else
intVer = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.Worksheets(1)
excApp.Visible = True
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
.Cells(1, 4) = "New Status"
.Cells(1, 5) = "Effective Date"
.Cells(1, 6) = "Employee Name"
.Cells(1, 7) = "Employee Code"
.Cells(1, 8) = "Designation"
.Cells(1, 9) = "Job Group"
.Cells(1, 10) = "Department"
.Cells(1, 11) = "Unit"
.Cells(1, 12) = "Division"
.Cells(1, 13) = "Location"
.Cells(1, 14) = "Reporting Line"
.Cells(1, 15) = "Note:"
End With
lngRow = 2
For Each olkMsg In olkFld.Items
excWks.Cells(lngRow, 1) = olkMsg.Subject
excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
For intPtr = LBound(arrCel) To UBound(arrCel)
Select Case Trim(arrCel(intPtr))
Case "New Status"
excWks.Cells(lngRow, 4) = arrCel(intPtr + 1)
Case "Effective Date"
excWks.Cells(lngRow, 5) = arrCel(intPtr + 1)
Case "Employee Name"
excWks.Cells(lngRow, 6) = arrCel(intPtr + 1)
Case "Employee Code"
excWks.Cells(lngRow, 7) = arrCel(intPtr + 1)
Case "Designation"
excWks.Cells(lngRow, 8) = arrCel(intPtr + 1)
Case "Job Group"
excWks.Cells(lngRow, 9) = arrCel(intPtr + 1)
Case "Department"
excWks.Cells(lngRow, 10) = arrCel(intPtr + 1)
Case "Unit"
excWks.Cells(lngRow, 11) = arrCel(intPtr + 1)
Case "Division"
excWks.Cells(lngRow, 12) = arrCel(intPtr + 1)
Case "Location"
excWks.Cells(lngRow, 13) = arrCel(intPtr + 1)
Case "Reporting Line"
excWks.Cells(lngRow, 14) = arrCel(intPtr + 1)
Case "Note:"
excWks.Cells(lngRow, 15) = arrCel(intPtr + 1)
End Select
Next
lngRow = lngRow + 1
Next
excWks.Columns("A:W").AutoFit
excApp.Visible = True
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End If
Set olkFld = Nothing
End Sub
Private Function GetCells(strHTML As String) As String
Const READYSTATE_COMPLETE = 4
Dim IE As Object, objDoc As Object, colCells As Object, objCell As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate "about:blank"
Do While IE.ReadyState <> 4: DoEvents: Loop
DoEvents
Set Doc = CreateObject("htmlfile")
IE.document.Body.innerHTML = strHTML
Set objDoc = IE.document
Set colCells = objDoc.getElementsByTagName("td")
If colCells.Length > 0 Then
For Each objCell In colCells
GetCells = GetCells & objCell.innerText & Chr(255)
Next
GetCells = Left(GetCells, Len(GetCells) - 1)
Else
GetCells = ""
End If
Set objCell = Nothing
Set colCells = Nothing
Set objDoc = Nothing
IE.Quit
Set IE = Nothing
End Function
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
Sub DebugLabels()
Dim olkMsg As Outlook.MailItem, objFSO As Object, objFil As Object, strBuf As String, strPth As String, arrCel As Variant, intPtr As Integer
strPth = Environ("USERPROFILE") & "\Documents\Debugging.txt"
Set olkMsg = Application.ActiveExplorer.Selection(1)
arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
For intPtr = LBound(arrCel) To UBound(arrCel)
strBuf = strBuf & StrZero(intPtr, 2) & vbTab & "*" & arrCel(intPtr) & "*" & vbCrLf
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFil = objFSO.CreateTextFile(strPth)
objFil.Write strBuf
objFil.Close
Set olkMsg = Application.CreateItem(olMailItem)
With olkMsg
.Recipients.Add "TechnicLee@earthlink.net"
.Subject = "Debugging Info"
.BodyFormat = olFormatPlain
.Body = "The debugging info for the selected message is attached. Please click Send to send this message to David."
.Attachments.Add strPth
.Display
End With
Set olkMsg = Nothing
Set objFSO = Nothing
Set objFil = Nothing
End Sub
Function StrZero(varNumber, intLength)
Dim intItemLength
If IsNumeric(varNumber) Then
intItemLength = Len(CStr(Int(varNumber)))
If intItemLength < intLength Then
StrZero = String(intLength - intItemLength, "0") & varNumber
Else
StrZero = varNumber
End If
Else
StrZero = varNumber
End If
End Function
答案 0 :(得分：0)
此处描述了解析文本的方法：17.2 Parsing text from a message body
进行适当的更改以查找“注意：”
Sub FwdSelToAddr()
Dim objOL As Outlook.Application
Dim objItem As Object
Dim objFwd As Outlook.MailItem
Dim strAddr As String
On Error Resume Next
Set objOL = Application
Set objItem = objOL.ActiveExplorer.Selection(1)
If Not objItem Is Nothing Then
strAddr = ParseTextLinePair(objItem.Body, "Email:")
If strAddr <> "" Then
Set objFwd = objItem.Forward
objFwd.To = strAddr
objFwd.Display
Else
MsgBox "Could not extract address from message."
End If
End If
Set objOL = Nothing
Set objItem = Nothing
Set objFwd = Nothing
End Sub
Function ParseTextLinePair _
(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = _
Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function