BTW here is my solution (based off the post I referenced at beginning of this thread).
Send Email Porton (please note this is generated from a userform) (Filed Headers have been changed from original to 'Field#")
Sub Sendmail()
'Dimension variables
Dim oOutlookApp As Object, oOutlookMessage As Object
Dim oFSObj As Object, oFSTextStream As Object
Dim rngeSend As Range, strHTMLBody As String, strTempFilePath As String
Dim myLastRow As Long
Dim bodyText As String
Dim SigString As String
Dim Signature As String
'Create an instance of Outlook (or use existing instance if it already exists
Set oOutlookApp = CreateObject("Outlook.Application")
'Create a mail item
Set oOutlookMessage = oOutlookApp.CreateItem(0)
With oOutlookMessage
.To = "someemail@somewhere.com"
.Subject = "Subject: " & Format(Now, "mmmm dd, yyyy") _
& " --- " & TextBox1.value & " (" & TextBox2.value & ")"
bodyText = _
"First Line of Message here Then date " _
& DTPicker1.value & vbCrLf & vbCrLf & "Field1: " & TextBox1.value & _
vbCrLf & "Field2: " & TextBox2.value & vbCrLf & "Field3: " & _
TextBox3.value & vbCrLf & "Field4: " & ComboBox1.value & vbCrLf & _
"Field5: " & ComboBox2.value & vbCrLf & "Field6: " & ComboBox3.value & _
vbCrLf & "Field7: " & ComboBox4.value & vbCrLf & _
"Field8: " & DTPicker1.value & vbCrLf & "Field9: " & _
DTPicker2.value & vbCrLf & "Field10: " & ComboBox5.value & vbCrLf _
& vbCrLf & "Field11: " & TextBox11.value & vbCrLf & vbCrLf & _
"Field12: " & TextBox12.value & vbCrLf & vbCrLf & _
"Field13: " & TextBox13.value & vbCrLf & "Field14: " & _
TextBox14.value
.Body = bodyText 'Put all the information in the email
End With
oOutlookMessage.Display
End Sub
Read Email Protion ( All items have been changed to match SendMail posted)
Option Explicit
Sub GetSepEmail()
Dim OutlookApp As Object
Dim OA_NameSpace As Object
Dim OA_Folder As Object
Dim OA_MailItem As Object
Dim ws As Worksheet
Dim Created As Boolean
Dim NextRecord As Long
Application.ScreenUpdating = False
Set ws = Workbooks.Add(xlWorksheet).Sheets(1)
ws.[A1] = "Field1"
ws.[B1] = "Field2"
ws.[C1] = "Field3"
ws.[D1] = "Field4"
ws.[E1] = "Field5"
ws.[F1] = "Field6"
ws.[G1] = "Field7"
ws.[H1] = "Field8"
ws.[I1] = "Field9"
ws.[J1] = "Field10"
ws.[K1] = "Field11"
ws.[L1] = "Field12"
ws.[M1] = "Field13"
ws.[N1] = "Field14"
NextRecord = 2
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
Created = True
If OutlookApp Is Nothing Then
MsgBox "Unable to start Outlook."
Exit Sub
End If
End If
On Error GoTo 0
Set OA_NameSpace = OutlookApp.GetNamespace("MAPI")
Set OA_Folder = OA_NameSpace.GetDefaultFolder(6)
OA_Folder.Items.Sort "Received", True
For Each OA_MailItem In OA_Folder.Items
If OA_MailItem Like "*SUBJECT*" Then
Dim OrderInfo As Variant
OrderInfo = GrabInfo(OA_MailItem.Body)
If IsArray(OrderInfo) Then
ws.Range(Cells(NextRecord, 1), Cells(NextRecord, 14)) = OrderInfo
NextRecord = NextRecord + 1
End If
End If
Next
If Created Then OutlookApp.Quit
Application.ScreenUpdating = True
Set OA_Folder = Nothing
Set OA_NameSpace = Nothing
Set OutlookApp = Nothing
End Sub
Private Function GrabInfo(message As String) As Variant
Dim tmpInfo(13) As String
Dim f As Integer
Const TMPFILE As String = "C:\Documents and Settings\" & Environ("username") & "\outlook_extraction.tmp"
If message = vbNullString Then GrabInfo = vbNullString: Exit Function
f = FreeFile
Open TMPFILE For Output As #f
Write #f, message
Close #f
f = FreeFile
Open TMPFILE For Input As #f
Do While Not EOF(f)
Dim tmpLine As String
Line Input #f, tmpLine
If InStr(1, tmpLine, ":") Then
Select Case UCase(Left(tmpLine, InStr(1, tmpLine, ":") - 1))
Case "FIELD1": tmpInfo(0) = SplitString(tmpLine, ":")
Case "FIELD2": tmpInfo(1) = SplitString(tmpLine, ":")
Case "FIELD3": tmpInfo(2) = SplitString(tmpLine, ":")
Case "FIELD4": tmpInfo(3) = SplitString(tmpLine, ":")
Case "FIELD5": tmpInfo(4) = SplitString(tmpLine, ":")
Case "FIELD6": tmpInfo(5) = SplitString(tmpLine, ":")
Case "FIELD7": tmpInfo(6) = SplitString(tmpLine, ":")
Case "FIELD8": tmpInfo(7) = SplitString(tmpLine, ":")
Case "FIELD9": tmpInfo(8) = SplitString(tmpLine, ":")
Case "FIELD10": tmpInfo(9) = SplitString(tmpLine, ":")
Case "FIELD11": tmpInfo(10) = SplitString(tmpLine, ":")
Case "FIELD12": tmpInfo(11) = SplitString(tmpLine, ":")
Case "FIELD13": tmpInfo(12) = SplitString(tmpLine, ":")
Case "FIELD14": tmpInfo(13) = SplitString(tmpLine, ":")
End Select
End If
Loop
Close #f
Kill TMPFILE
GrabInfo = tmpInfo
End Function
Private Function SplitString(value As String, delimeter As String) As String
SplitString = Trim(Mid(value, InStr(1, value, delimeter) + 2, Len(value) - InStr(1, value, delimeter)))
End Function
.. I would like to work thru this with you since you are the author of the above macro.
