okay im super new to vb but have managed to find most of the code i need to import in emails( i have a website freehomerefi.com) where users fill out info and it than sends me there info in the body of an email. i would like to import all of those emails into excel so i can sort the data easily, Here is the code im using along with a copy of the fields im trying to import. any help would be appreciated as im getting no where quick. Also is it possible to automate this process?


Option Explicit

Sub ExportToExcel()

On Error GoTo ErrHandler

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "OutlookItems.xls"
strPath = "C:\Examples\"
strSheet = strPath & strSheet
Debug.Print strSheet

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
Next itm
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1
intColumnCounter = intColumnCounter + 1
If msg.field <> "" Then rng.Value = msg.field
Exit Sub

ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

End Sub

Here is an example of the info i get in the email

Customer Name: John Do

Day Phone: 606 555-1212

Evening Phone: 606-555-1212

Best Time to Call: 10 a.m - 12 p.m.

Email: thinkle3991232324@newwavecomm.net

Street Address: 16545343 Super Fake Hollow Rd.

State: Kentucky

City: Corbin

ZIP: 40701

Credit Profile: good

Loan Purpose: Debt Consolidation

Desired Loan Amount: 220000

Estimated Home Value: 260000

Type of Home: Single Family

Current Mortgage Balance: 186000

Current Interest Rate: 5.75

2nd Mortgage Balance: 0

2nd Mortgage Rate: 0

Debt Type: My Credit Card Debt

Amount Of Debt: $20,000 - $25,000

Sales ID: