lundi 20 avril 2015

how to export message body and data from Table to Excel from outlook 2010

I usually get Employee announcement in emails and I need to compile excel sheet from all these emails to know change in status of employee from previous line to current line .

Dear Concerned,

The change in status of the following employee has been carried out as per following details:

New Status

Change in Job

Effective Date

01-Feb-2015

Employee Name

Ricky ponting

Employee Code

4982

Designation

Sourcing Executive (Secondment)

Job Group

1A

Department

Sourcing & Supply Chain

Unit

Technology Sourcing

Division

Finance

Location

Islamabad

Reporting Line

Mr Micheal king

Note: Ricky Ponting was previously working as Tariff Implementation Support Officer in the org Communication dept and was reporting to Mr Robin Sing.

I need working code that export about HTML table data as well last Note : full line so that I can have an excel file of 2000 Employees whoes status have been changed and I can easily sort out from which previous line they were reporting to new line and I can get in touch with the new line for any Access rights re-authorization exercise on later stage .

Currently i am using following code thats working fine with the table extraction but NOTE: line is not being fetched with the following code based on following URL

http://ift.tt/1yLZ6vS

    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://ift.tt/1mlp9DO")
    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

Aucun commentaire:

Enregistrer un commentaire