Hi Everyone

I've come across a macro which I have tried using, but nothing seems to
happen. This macro is run from Excel and interacts with Outlook, so I've made
sure to turn on the Microsoft Outlook 11.0 Object Library in TOOLS -
REFERENCES from the VBE window.

If Outlook is not running, I do get the error message I'm supposed to get
(i.e. "No message selected"), but beyond that I have absolutely no indication
that the Macro actually does anything.

The code is as follows:

Sub CopyFromOutlook()
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim myArray(8) As String
Dim Line As Long, Addr1 As String
Dim Tabl, str As String, EmailAddress, DOB
Dim i As Integer, x As Integer, n As Integer, j As Integer

On Error Resume Next
' Getting the messages selection
Set olApp = Outlook.Application
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
' Checking if there is at least one message selected
If olSel.Count < 1 Then
MsgBox "No message selected", vbExclamation, "Error"
Exit Sub
End If
With Sheets("EditData")
' Retrieving the first avaible row to put message in
Line = .Range("A65000").End(xlUp).Row + 1
' looping through message
For x = 1 To olSel.Count
DoEvents
Erase myArray
mybody = Replace(olSel.Item(x).body, Chr(13), "")
' Splitting the message body into an array of substrings,
' using the "line feed" characters as separators
'mybody = Replace(mybody, Chr(10) & Chr(10), Chr(10))
Tabl = Split(mybody, Chr(10))
For Each Item In Tabl
Item = Replace(Item, Chr(10), "")
Item = Application.Clean(Item)
Next Item
' Looping through these substrings
For i = 0 To UBound(Tabl)
' Looking for the surname field
If LCase(Left(Tabl(i), 9)) = "last name" Then
.Cells(Line, 2) = Application.Proper(Mid(Tabl(i), 13, 999))
ElseIf LCase(Left(Tabl(i), 10)) = "othsurname" Then
.Cells(Line, 2) = Application.Proper(Mid(Tabl(i), 14, 999))
' Looking for the first name field
ElseIf LCase(Left(Tabl(i), 10)) = "first name" Then
.Cells(Line, 1) = Application.Proper(Mid(Tabl(i), 14, 999))
ElseIf LCase(Left(Tabl(i), 12)) = "othfirstname" Then
.Cells(Line, 1) = Application.Proper(Mid(Tabl(i), 16, 999))
' Looking for the zip code
ElseIf Left(Tabl(i), 11) = "Postcode = " Then
.Cells(Line, 7) = Mid(Tabl(i), 12, 999)
' Looking for the date of birth field
ElseIf Left(Tabl(i), 3) = "DOB" Then
If IsDate(Mid(Tabl(i), 7, 999)) Then
.Cells(Line, 8) = CDate(Trim(Mid(Tabl(i), 7, 999)))
End If
'looking for the address
ElseIf UCase(Left(Tabl(i), 5)) = "LINE1" Then
.Cells(Line, 3) = Mid(Tabl(i), 8, 999)
ElseIf UCase(Left(Tabl(i), 5)) = "LINE2" Then
.Cells(Line, 4) = Mid(Tabl(i), 8, 999)
ElseIf UCase(Left(Tabl(i), 6)) = "TOWN =" Then
.Cells(Line, 5) = Mid(Tabl(i), 7, 999)
ElseIf UCase(Left(Tabl(i), 11)) = "TOWN/CITY =" Then
.Cells(Line, 5) = Mid(Tabl(i), 12, 999)
ElseIf UCase(Left(Tabl(i), 6)) = "COUNTY" Then
.Cells(Line, 6) = Mid(Tabl(i), 9, 999)
' Looking for the email address
ElseIf UCase(Left(Tabl(i), 7)) = "EMAIL =" Then
.Cells(Line, 9) = Mid(Tabl(i), 9, 999)
ElseIf UCase(Left(Tabl(i), 11)) = "FROMEMAIL =" Then
.Cells(Line, 9) = Mid(Tabl(i), 13, 999)
End If
Next i
Line = Line + 1
' Next message
Next x
End With
End Sub


Any help would be greatly appreciated. I'm running Outlook 2003 and Excel
2003.

Thanks,

Joe.
--
If you can measure it, you can improve it!