Help with Macro please...

[Monomeeth]

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.

 

[Monomeeth]

Oops, forgot to mention that I have tried selecting messages in Outlook
before running the Macro in Excel, but this seems to have no effect. Not
selecting any messages beforehand also has no effect.

 

[Tim Williams]

What happens if you remove the "On Error Resume Next" ?

Tim

 

[K_Macd]

If you have a genuine error removing "on error resume next'" will highlight
the vicinity of the error but why not be more pro-active. There are some good
debugging tools within the VBE environment such as step, local variables and
breakpoints. The effort to become familiar with these will more than repay
itself if you want to quickly debug any sort of code especially where the
error stems from poor or illogical code structure.

 

[Monomeeth]

Hi Tim

Thanks for the suggestion. I removed it and there was no noticeable
difference - exactly the same result.

I don't suppose you'd have any other ideas?

Joe.

 

[Monomeeth]

Hi Ken

Thanks for the suggestion. I did have a bit of a play (I'm no expert by any
means) with the debugging tools, but there appears to be no error! I am now
wondering whether the "data" the macro is looking for is not actually there
and therefore that's why nothing is getting imported.

What I mean is, if the Macro is looking for something called "last name" but
Outlook's field is actually called something else like "Surname" then the
macro isn't going to find it. I might go and investigate this approach and
see what happens - This isn't my macro so I'm working a little blind here.

Thanks for your help!

Joe.

 

[Tim Williams]

Your code works for me in that it will fetch the body of all the
messages selected in my outlook inbox.

So, if you're not getting any data the problem must be in your parsing
code.
Hard to tell without a sample message to look at.

Comment on this:

Tabl = Split(mybody, Chr(10))
For Each Item In Tabl
Item = Replace(Item, Chr(10), "") '**** not required
Item = Application.Clean(Item)
Next Item

If you've split the text into lines on Chr(10), there should be no Chr
(10) in any of the lines, so you can omit that line.

You might also consider splitting out the "search" part into a
separate function

Function GetValue(arrLines, LookFor As String) As String
Dim x As Integer
Dim rv As String, line As String

rv = ""
For x = LBound(arrLines) To UBound(arrLines)
line = arrLines(x)
If LCase(line) Like LookFor & "*" Then
rv = Mid(line, Len(LookFor) + 4, 999)
Exit For
End If
Next x
GetValue = rv

End Function

Call using something like:

tmp = GetValue(Tabl,"first name")
.Cells(2).value = Application.Proper(tmp)

If you could post an example (altered if required) of a typical
message body that would help.

Tim