Copy from Lotus note body in mail to excel cells.

HI. All.

I need an excel macro to get different data from lotus notes text body and paste it into excel cells. I've looked hard searching through the Internet but it seems as is everybody is only interested in sending e-mails but not getting text data. Hope someone can help out here.
So I guess this is a one of the hard ones.

I found below code but in my excel 2003 I never reach to be able to test it, it give me errors.
But maybe some of the experts here can use it or change it or maybe some know another code to use.


Thanks in advance.

Sincerely

Abjac

My found not working code.

Sub Initialize
    
    On Error Resume Next
    
    Dim dbSession             As New NotesSession
    Dim db                          As NotesDatabase
    Dim curView                  As NotesView
    Dim StatDoc                  As NotesDocument
    Dim ExcelPath             As String
    Dim ExcelFileName     As String
    Dim MSAction             As String
    Dim path                     As String
    Dim oExcel                 As Variant
    Dim oWorkbook             As Variant
    Dim openExcel             As Integer
    
'connect to the current opened Database
    Set db = dbSession.CurrentDatabase
    
'set the current view, filename and refresh
    Set curView = db.GetView ( "All")
    DefaultFileName$="c:\All"+".xls"
    Call curView.Refresh
    If curView Is Nothing Then
        Messagebox "View does not exist"
        End 
    End If
    
'get the first document in the view and check for an empty view
    Set StatDoc = curView.GetFirstDocument
    If StatDoc Is Nothing Then
        Messagebox "Current View is empty."
        End
    End If
    
    Set oExcel = CreateObject ( "Excel.Application" )
    
    ExcelPath = DefaultPath$
    
    path = oExcel.Path
    oExcel.Quit
    Set oExcel = Nothing
    
    Call ExportToExcel ( ExcelPath, DefaultFileName$, curView)
    If Instr ( ExcelFileName, " " ) > 0 Then
        DefaultFileName$ = {"} & DefaultFileName$ & {"}
    End If
    openExcel = Shell ( path & "\excel.exe " &DefaultFileName$, 3 )
    
exit_sub:
    If Not oExcel Is Nothing Then
        oExcel.Quit
        Set oExcel = Nothing
    End If
    
    Exit Sub
    
End Sub

Sub ExportToExcel ( ExcelPath As String, ExcelFileName As String, curView As NotesView)
    
    Dim curDoc                 As NotesDocument
    Dim oExcel                 As Variant
    Dim oWorkbook            As Variant
    Dim oWorkSheet         As Variant
    Dim i                         As Double
    
    On Error Resume Next
    
'Automate Excel, add a workbook and a worksheet    
    'Set oExcel = CreateObject ( "Excel.Application" )
    Set oExcel = CreateObject("Excel.Application")
    'Set oWorkbook = oExcel.Workbooks.Add(1)
    'Set oWorkSheet= oWorkbook.Sheets ( 1 )
    Set oWorkbook = oExcel.Workbooks.Open("C:\All.xls")
    If Err Then
        Msgbox "here"
        Set oWorkbook = oExcel.Workbooks.Add(1)
        oWorkbook.SaveAs ( "C:\All.xls" )
    End If
    
    Set oWorkSheet= oWorkbook.Sheets ( "Sheet1" )
    
    'Set oWorksheet = oWorkbook.Worksheets(1)
    'oExcel.Cells(1, 1).Value = 11
    'oWorkbook.WorkSheets(1).Range("A1").Value = "TEST"
    'oWorkSheet.Range("A1").Value = "AAAA"    
    'oExcel.Visible = True
    
    oWorkSheet.Cells.Select
    oWorkSheet.Range("A1:M10000").ClearContents
    
    'End 
    
'Start reading information in the view. If view is empty, then quit
    Set curDoc = curView.GetFirstDocument
    If curDoc Is Nothing Goto exit_sub
    
'This section adds headings in row 2    
    oWorkSheet.Range("A1").Value = "Requested by"
    oWorkSheet.Range("B1").Value = "Analyst"
    oWorkSheet.Range("C1").Value = "Date Created"
    oWorkSheet.Range("D1").Value = "Est. Start Date"
    oWorkSheet.Range("E1").Value = "Act Start Date"
    oWorkSheet.Range("F1").Value = "Est. Complete Date"
    oWorkSheet.Range("G1").Value = "Actual Complete Date"
    oWorkSheet.Range("H1").Value = "Category"
    oWorkSheet.Range("I1").Value = "Department"
    oWorkSheet.Range("J1").Value = "Summary"
    oWorkSheet.Range("K1").Value = "Request Title"
    oWorkSheet.Range("L1").Value = "Comments"
    oWorkSheet.Range("M1").Value = "Status"
    oWorkSheet.Range("N1").Value = "Priority"
    oWorkSheet.Range("O1").Value = "Work Weeks"
    oWorkSheet.Range("P1").Value = "Process Name"
    oWorkSheet.Range("Q1").Value = "Process Owner"
    oWorkSheet.Range("R1").Value = "User Priority"
    oWorkSheet.Range("S1").Value = "Management Sponsor"
    oWorkSheet.Range("T1").Value = "Team / Resources"
    oWorkSheet.Range("U1").Value = "Root Cause"
    oWorkSheet.Range("V1").Value = "Proposed Solution"
    oWorkSheet.Range("W1").Value = "Alternatives"
    oWorkSheet.Range("X1").Value = "Target Implementation Date"
    oWorkSheet.Range("Y1").Value = "Estimated Costs (out of pocket)"
    oWorkSheet.Range("Z1").Value = "Estimated Costs (internal)"
    oWorkSheet.Range("AA1").Value = "Business Benefits"
    oWorkSheet.Range("AB1").Value = "Post Implementation KPIs"
    
    
'The first row that will contain view data is 2    
    i = 2    
    
    Do Until curDoc Is Nothing
        
'This section adds the view information to excel
        oWorkSheet.Range ( "A" & i  ).Value = curDoc.txtCreator(0)
        oWorkSheet.Range ( "B" & i  ).Value = curDoc.cmbAnalyst(0)
        oWorkSheet.Range ( "C" & i ).Value = curDoc.dtDateCreated(0)
        oWorkSheet.Range ( "D" &  i  ).Value = curDoc.dtEstStartDate(0)
        oWorkSheet.Range ( "E" & i  ).Value = curDoc.dtActStartDate(0)
        oWorkSheet.Range ( "F" &  i  ).Value = curDoc.dtEstCompDate(0)
        oWorkSheet.Range ( "G" &  i  ).Value = curDoc.dtActCompDate(0)
        oWorkSheet.Range ( "H" &  i  ).Value = curDoc.dlCategory(0)
        oWorkSheet.Range ( "I" & i  ).Value = curDoc.dlDepartment(0)
        oWorkSheet.Range ( "J" & i  ).Value = curDoc.rtBRAB(0)
        oWorkSheet.Range ( "K" & i  ).Value = curDoc.txtRequestTitle(0)
        oWorkSheet.Range ( "L" & i  ).Value = curDoc.rtComments(0)
        oWorkSheet.Range ( "M" & i  ).Value = curDoc.txtOCStatus(0)
        oWorkSheet.Range("N" & i).Value = curDoc.txtPriority(0)
        oWorkSheet.Range("O" & i).Value = curDoc.txtEstWorkWeek(0)
        oWorkSheet.Range("P" & i).Value = curDoc.txtProcessName(0)
        oWorkSheet.Range("Q" & i).Value = curDoc.txtProcessOwner(0)
        oWorkSheet.Range("R" & i).Value = curDoc.cmbUserPriority(0)
        oWorkSheet.Range("S" & i).Value = curDoc.txtSponsor(0)
        oWorkSheet.Range("T" & i).Value = curDoc.txtTeamResources(0)
        oWorkSheet.Range("U" & i).Value = curDoc.txtRootCause(0)
        oWorkSheet.Range("V" & i).Value = curDoc.txtProposedSolution(0)
        oWorkSheet.Range("W" & i).Value = curDoc.txtAlternatives(0)
        oWorkSheet.Range("X" & i).Value = curDoc.dtTargetImpDate(0)
        oWorkSheet.Range("Y" & i).Value = curDoc.txtOutOfPocket(0)
        oWorkSheet.Range("Z" & i).Value = curDoc.txtInternal(0)
        oWorkSheet.Range("AA" & i).Value = curDoc.txtEstBenefits(0)
        oWorkSheet.Range("AB" & i).Value = curDoc.txtPostImpKPIs(0)
        
'Increment to the next row
        i = i + 1
        
'Increment to the next document        
        Set curDoc = curView.GetNextDocument ( curDoc )
        
    Loop
    
Exit_Sub:
'Take our objects out of memory, save file, and quit excel
    Set oWorkSheet= Nothing
    oWorkbook.Save
    Set oWorkbook = Nothing
    oExcel.Quit
    Set oExcel = Nothing    
End Sub

I'd be interested in seeing any responses too this one myself.

Hi. John Yes lets see if there will be any answers I think this is a very complicated one. So lets hope some have the knowledge.

ABjac

HI Thanks to John W on Osgrid he provided this below code. It works and open all mail in the inbox and display it in note pad. I need it to be changed to only open the mail which is open and display it in excel.
So have a look

Thanks

Public Sub Get_Notes_Email_Text() 
     
    Dim NSession As Object 'NotesSession
    Dim NMailDb As Object 'NotesDatabase
    Dim NDocs As Object 'NotesDocumentCollection
    Dim NDoc As Object 'NotesDocument
    Dim NNextDoc As Object 'NotesDocument
    Dim NItem As Object 'NotesItem
    Dim view As String 
    Dim filterText As String 
     
    view = "$All" 'Name of view or folder to retrieve documents from
    view = "$Inbox" 
    filterText = "" 'Optional text string to filter the view
     
    Set NSession = CreateObject("Notes.NotesSession") 
    Set NMailDb = NSession.GetDatabase("", "") 'Default server and database
     
    If Not NMailDb.IsOpen Then NMailDb.OpenMail 
     
    Set NDocs = NMailDb.GetView(view) 
    NDocs.Clear 
     
     'Apply optional filter
     
    If filterText <> "" Then 
        NDocs.FTSearch filterText, 0 
    End If 
     
    Set NDoc = NDocs.GetFirstDocument 
    Do Until NDoc Is Nothing 
        Set NNextDoc = NDocs.GetNextDocument(NDoc) 
        Set NItem = NDoc.GetFirstItem("Body") 
        If Not NItem Is Nothing Then 
            MsgBox prompt:=NItem.Text, Title:=NDoc.GetItemValue("Subject")(0) 
        End If 
        Set NDoc = NNextDoc 
    Loop 
     
    NMailDb.Close 
    NSession.Close 
     
    Set NSession = Nothing 
     
End Sub

Thanks to John_W on Osgrid this thread is solved. He delivered a brilliant code. I cant vote there but here I will give the solution 5 stars.
The final code is like this.

Public Sub Lotus_Notes_Current_Email2() 
     
    Dim NSession As Object 'NotesSession
    Dim NUIWorkspace As Object 'NotesUIWorkspace
    Dim NUIDoc As Object 'NotesUIDocument
    Dim NItem As Object 'NotesItem
    Dim lines As Variant 
     
    Set NSession = CreateObject("Notes.NotesSession") 
    Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace") 
     
    Set NUIDoc = NUIWorkspace.CurrentDocument 
    If Not NUIDoc Is Nothing Then 
        With NUIDoc.Document 
            Set NItem = .GetFirstItem("Body") 
            If Not NItem Is Nothing Then 
                lines = Split(NItem.Text, vbCrLf) 
                Range("A2").Resize(UBound(lines) + 1, 1).Value = Application.WorksheetFunction.Transpose(lines) 
            End If 
        End With 
    Else 
        MsgBox "Lotus Notes is not displaying an email" 
    End If 
     
    Set NUIDoc = Nothing 
    Set NUIWorkspace = Nothing 
    Set NSession = Nothing 
     
End Sub

Playing around with your last post, this appears to get the data into the activecell.

Sub abjac()
     
    Dim NSession As Object 'NotesSession
    Dim NUIWorkspace As Object 'NotesUIWorkspace
    Dim NUIDoc As Object 'NotesUIDocument
    Dim NItem As Object 'NotesItem
     
    Set NSession = CreateObject("Notes.NotesSession")
    Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
     
    Set NUIDoc = NUIWorkspace.CurrentDocument
    If Not NUIDoc Is Nothing Then
        With NUIDoc.Document
            Set NItem = .GetFirstItem("Body")
            If Not NItem Is Nothing Then
                ActiveCell.Value = NItem.Text ', Title:=.GetItemValue("Subject")(0)
            End If
        End With
    Else
        MsgBox "Lotus Notes is not displaying an email"
    End If
     
    Set NUIDoc = Nothing
    Set NUIWorkspace = Nothing
    Set NSession = Nothing
     
End Sub

Probably can specify a destination range as well.

HI. John yes in my last post here the start cell is displayed. So for me this is brilliant.

Sincerely

Abjac