Mails fra Outlook til Excel

Hej Eksperter!

Jeg har et spørgsmål angående, hvorledes man får en mail fra Outlook 2003 over i Excel 2003.

Jeg skal have flyttet en del mails over i Excel, da jeg skal bruge dem til en database med over 2000 rækker, så at importere de enkelte mails manuelt er en kende overkill.

Body'en i mails'ne er følgende:

Navn: X
Stilling: W
Sted: S
Hobby: D
Skostørrelse: Z

(Nogle lidt andre kategorier, men meningen er der forhåbentlig..)
Linjerne er ikke kommasepareret, men står ligesom indholdet normalt gør i en mail/tekstfil.

Jeg vil gerne have indholdet til at stå således at emnet står i kolonnerne, og indholdet står i rækker, da alle mails har den samme form, eks:

Navn:    Stilling:  Sted:  Hobby:  Skostørrelse:
X        W          S      D        Z


Jeg har fundet en VBA-kode der kan overføre mails til Excel. Problemet er blot at selve indholdet i mailen (eller Body) er samlet i en celle.

Denne kode ser således ud:

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 folderSet 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.ReceivedTime

Set rng = wks.Cells(intRowCounter, intColumnCounter)   
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1

Next itm  Set appExcel = Nothing  Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing  Exit SubErrHandler:  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 = NothingEnd Sub

Koden skal køres fra Outlook.
Er det muligt for mig at udvide ovenstående kode, eller skal jeg anvende en helt anden?

Med venlig hilsen

Trolle17