how to append data from outlook into excel

[paulus4605]

case:

I get mails dispatched

this mail has as subject : FW blablabla

in this mail I have in the body the text

mailnummer: 935

I am able to retrieve the subject and mailnummer however I am not able to append this to an excisting excel sheet where already data is present

how do I do this?

at this point it gives me a msgbox with the info cause I don't know how to add this info into an excisting excel sheet with the condition that he has to enter the data on the first empty row that's available

thanks in advance for your help

Sub SaveMessages()

'Declaration
Dim myItems, myItem As Object
Dim myOrt As String
Dim strdate As String
Dim newdate As String
Dim strname As String
Dim newstr As String
Dim i As Integer

Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim FindTerm(13)

'Set invalid characters to replace
FindTerm(0) = "*"
FindTerm(1) = "@"
FindTerm(2) = "\"
FindTerm(3) = "("
FindTerm(4) = ")"
FindTerm(5) = "["
FindTerm(6) = "]"
FindTerm(7) = "?"
FindTerm(8) = "<"
FindTerm(9) = ">"
FindTerm(10) = "!"
FindTerm(11) = "{"
FindTerm(12) = "}"
FindTerm(13) = ":"

'Ask for destination folder
myOrt = ("C:\TEMP\")

On Error Resume Next

'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

'for all items do...
For Each myItem In myOlSel

strdate = myItem.SentOn
newdate = Format(strdate, "yyyymmddhhmm")
strname = newdate & "-" & myItem.Subject & ".msg"

For i = 1 To 13
newstr = Replace(strname, FindTerm(i), " ")
strname = newstr
Next
'myItem.SaveAs myOrt & newstr
MsgBox GetMailID(myItem.HTMLBody) & " - " & myItem.Subject
'myItem.Delete

Next

'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub



Private Function GetMailID(sBody As String) As String
Dim aTmp() As String
Dim i As Integer
aTmp = Split(sBody, vbCrLf)
For i = 0 To UBound(aTmp)
If InStr(1, aTmp(i), "mail", vbTextCompare) > 0 Then
GetMailID = Right(aTmp(i), Len(aTmp(i)) - InStr(1, aTmp(i), "mail", vbTextCompare) + 1) 'Mid(aTmp(i), InStr(1, aTmp(i), "mail", vbTextCompare), InStr(1, aTmp(i), "mail", vbTextCompare) - InStr(InStr(1, aTmp(i), "mail", vbTextCompare), aTmp(i), "<"))
GetMailID = Left(GetMailID, InStr(1, GetMailID, "<", vbTextCompare) - 1)
Exit For
End If
Next i
End Function