I am using Excel 2010 and Outlook 2010. What I am trying to do is copy the contents of an email into an excel spreadsheet. Currently I can pick the right email and I can copy and paste into the worksheet. The problem is the paste function is pasting into 1 cell instead of multiple cells. So I am not getting all the data because I have maxed out the contents of the cell. Is there a way of copying the contents one line at a time? Currently I am copying the whole email at once. Tom
Code:
Public Sub Dwnld_NetAdds()
Dim strDate1 As String
Dim strDate2 As String
Dim strDate3 As String
Dim strDateType1 As String
Dim strDateType2 As String
Dim strDateType3 As String
Dim strFile As String
Dim FolderTgt As MAPIFolder
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim strPath As String
Dim RowCrnt As Long
Dim TextBody As String
Dim xlApp As Excel.Application
Dim ObjOutlook As Object
Dim objFolder As MAPIFolder
Dim objMailbox As Object
Dim objNamespace As Namespace
Dim objInbox As Outlook.MAPIFolder
Dim strFolderName As String
Dim objItem As Object
Dim strRcvDate As String
Const olFolderInbox = 6
Set ObjOutlook = CreateObject("Outlook.Application")
Set objNamespace = ObjOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set FolderTgt = objMailbox.Folders("DailyNetAdds")
strPath = "\\cable\ncd-shared\DIV-FIN-Business-Analytics-Shared\Adhoc\Tom\DOR\Daily Net Adds\"
strDateType1 = "C_M/D/YYYY"
strDateType2 = "C_MMM YYYY"
Call DefineDateType(strDate1, strDate2, strDate3, strDateType1, strDateType2, strDateType3)
strRcvDate = strDate1
strFile = "NorthEast Daily Forecast - " & strDate2 & ".xlsm"
' Open copy of Excel
Set xlApp = CreateObject("Excel.Application")
Set xlBook1 = xlApp.Workbooks.Open(strPath & strFile)
xlApp.Visible = True
For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
With FolderTgt.Items.Item(InxItemCrnt)
If strRcvDate <> Date Then
With Worksheets("Forecast")
RowCrnt = RowCrnt + 1
If TextBody <> "" Then
With .Cells(RowCrnt, "A")
' The maximum size of a cell 32,767
.Value = Mid(TextBody, 1, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
TextBody = Replace(TextBody, Chr(160), "~")
TextBody = Replace(TextBody, vbCr, "~")
TextBody = Replace(TextBody, vbLf, "~")
TextBody = Replace(TextBody, vbTab, "~")
TextBody = Replace(TextBody, "~", "")
With .Cells(RowCrnt, "B")
' The maximum size of a cell 32,767
.Value = Mid(TextBody, 2, 32700)
.WrapText = True
End With
RowCrnt = RowCrnt + 1
End If
End With
End If
End With
Next
Set xlApp = Nothing ' Clear reference to Excel
End Sub