RobWulf
05-02-2013, 02:27 PM
Okay, I got this code to work, but I want to open an excel file then write the data to the fields.
Sub Extract()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
'Set book = GetObject("C:\Users\h108718\Desktop\MailBoxLog - Copy.xlsm")
xlobj.Visible = True
xlobj.workbooks.Add
'Set Heading
'xlobj.Range("e" & 1).Value = "Body"
'Not saving the body at this time.
xlobj.Range("a" & 1).Value = "Recieved Date"
xlobj.Range("b" & 1).Value = "Sender"
'xlobj.Range("D" & 1).Value = "Recipiant"
'decided against saving the Recipiant, just creates a lot of clutter when others are also listed.
xlobj.Range("D" & 1).Value = "Subject"
'xlobj.Range("F" & 1).Value = "Categories"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
'xlobj.Range("E" & i + 1).Value = msgtext
xlobj.Range("A" & i + 1).Value = myitem.ReceivedTime
xlobj.Range("B" & i + 1).Value = myitem.Sender
xlobj.Range("D" & i + 1).Value = myitem.Subject
'xlobj.Range("F" & i + 1).Value = myitem.Categories
'xlobj.Range("D" & i + 1).Value = myitem.To
Next
End Sub
It works great aside from the fact it creates a new workbook every time, I just want to be able to tell it where the file is located and have it write the above data to those columns.
Thanks for looking.
Sub Extract()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
'Set book = GetObject("C:\Users\h108718\Desktop\MailBoxLog - Copy.xlsm")
xlobj.Visible = True
xlobj.workbooks.Add
'Set Heading
'xlobj.Range("e" & 1).Value = "Body"
'Not saving the body at this time.
xlobj.Range("a" & 1).Value = "Recieved Date"
xlobj.Range("b" & 1).Value = "Sender"
'xlobj.Range("D" & 1).Value = "Recipiant"
'decided against saving the Recipiant, just creates a lot of clutter when others are also listed.
xlobj.Range("D" & 1).Value = "Subject"
'xlobj.Range("F" & 1).Value = "Categories"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
'xlobj.Range("E" & i + 1).Value = msgtext
xlobj.Range("A" & i + 1).Value = myitem.ReceivedTime
xlobj.Range("B" & i + 1).Value = myitem.Sender
xlobj.Range("D" & i + 1).Value = myitem.Subject
'xlobj.Range("F" & i + 1).Value = myitem.Categories
'xlobj.Range("D" & i + 1).Value = myitem.To
Next
End Sub
It works great aside from the fact it creates a new workbook every time, I just want to be able to tell it where the file is located and have it write the above data to those columns.
Thanks for looking.