ForSale ..


You owe me :)


Edit the scanfolder's name.... it does inbox now ..
scanfolder CAN be \\store\folder\subfolder

if store is not specified it will pick the first available
store in the current session.

Problem with IDing a 4number string is that you'll find
that several phone numbers and dates will popup as well..

I've tried to find ALL occurances of 'four number words'
dumped in the activesheet

adapt as needed...
signing for tonite...email me for follow up.
somehow I think there will be some... :)

Have Fun!


--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


Option Explicit

Sub OutlookReader()
Dim olApp As Outlook.Application
Dim olSes As Outlook.NameSpace
Dim olFol As Outlook.MAPIFolder
Dim olObj As Object
Dim rdObj As Object

On Error GoTo errH:
Set olApp = CreateObject("Outlook.application")
Set olSes = olApp.Session

Set olFol = GetFolder(olSes, "Inbox")

For Each olObj In olFol.Items
If olObj.Class = olMail Then
'Set rdObj = CreateObject("Redemption.SafeMailItem")
'rdObj.Item = olObj
'Call FindID(rdObj)
Call FindID(olObj)
End If
Next

endH:
On Error Resume Next
'Cleanup Redemption
'Set rdObj = Nothing
'CreateObject("Redemption.MAPIUtils").Cleanup

Set olObj = Nothing
Set olFol = Nothing
Set olSes = Nothing
Set olApp = Nothing
Exit Sub

errH:


End Sub

'Returns the object from a path like \\Store\Folder\SubFolder
Function GetFolder(ByRef oSes As Outlook.NameSpace, ByVal sPath As
String) As MAPIFolder

Dim vArr, oFld, i%
On Error GoTo errH:
If Left(sPath, 2) < "\\" Then
sPath = oSes.Folders(1).FolderPath & IIf(Left(sPath, 1) = "\", "",
"\") & sPath
End If
vArr = Split(Replace(Replace(sPath, "/", "\"), "\\", ""), "\")

Set oFld = oSes.Folders(vArr(0))
If oFld Is Nothing Then Exit Function
For i = 1 To UBound(vArr)
Set oFld = oFld.Folders(vArr(i))
Next

Set GetFolder = oFld
Exit Function
errH:
MsgBox "Cant find folder " & sPath
End Function

Sub FindID(olMsg As Object)
Dim i&
Dim sMsg As String
Dim sRaw As String
Dim bFound As Boolean

sRaw = olMsg.Body
If sRaw Like "*####*" Then
sMsg = " " & sRaw & " "
If sMsg Like "*" & vbCrLf & "*" Then sMsg = Replace(sMsg, vbCrLf, "
")
If sMsg Like "*" & vbLf & "*" Then sMsg = Replace(sMsg, vbLf, " ")
If sMsg Like "*" & vbCr & "*" Then sMsg = Replace(sMsg, vbCr, " ")

For i = 1 To Len(sMsg) - 5
If Mid(sMsg, i, 6) Like " #### " Then
Call WriteID(olMsg, Mid(sMsg, i + 1, 4))
bFound = True
If Not Mid(sMsg, i + 6) Like "*#### *" Then Exit For
End If
Next
End If
If Not bFound Then Call WriteID(olMsg, "none")
End Sub

Sub WriteID(olMsg As Object, sID As String)
Static s_rng As Range
If s_rng Is Nothing Then
Set s_rng = ActiveSheet.Columns("A:A").Cells(2 ^ 16, 1).End(xlUp)
End If
Set s_rng = s_rng.Offset(1)
With s_rng
.Resize(1, 3) = Array(olMsg.SenderName, olMsg.Subject, sID)
End With
End Sub