jim may
Well-known Member
- Joined
- Jul 4, 2004
- Messages
- 7,484
I found (and borrowed) the following code from somewhere (no longer sure from where)
Not sure it is what I need now - due to errors, but: Is there a better way?;
The error is occuring 8 out of 10 times (My Inbox contains 80 unique e-mails). Can anyone
spot a problem in the code for me. Thanks very much for any assitance. Also, Version 2003 of both Outlook and Excel are in use here.
Jim
Sub SingleRequest() 'Populate requested Store Number with Current Outlook e-mail for same
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim Subj As String
Dim recTime As Date
Dim stBody As String
Dim StNum As String
Dim LineBreak As Long
Dim i As Long
Dim ctr As Long
Application.ScreenUpdating = False
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("Personal Folders-Jim").Folders("Inbox").Folders("StopIn")
ActiveSheet.Range("A1:B200").ClearContents
ctr = 0
For Each olMail In Fldr.Items
Subj = olMail.Subject
StNum = ExtractNum(olMail.Subject)
If StNum = Range("C1").Value Then
recTime = olMail.ReceivedTime
ctr = ctr + 1
With ActiveSheet
.Cells(1, 1).Value = Subj
.Cells(1, 2).Value = recTime
.Columns(2).AutoFit
End With
stBody = olMail.Body
LineBreak = 1
i = 3
Do ' Getting R/T error Invalid Procedure call or argument (on Next line)
ActiveSheet.Cells(i, 1).Value = _
Mid(stBody, LineBreak, InStr(LineBreak, stBody, Chr(10)) - LineBreak)
LineBreak = InStr(LineBreak + 1, stBody, Chr(10)) + 1
i = i + 1
Loop Until LineBreak = 0 Or LineBreak > Len(stBody)
Exit Sub 'Quit Macro
End If
Next olMail
If ctr = 0 Then
MsgBox Range("D1").Value & " has not reported in today - " & Format(Date, "mmmm dd, yyyy")
End If
ActiveSheet.Columns(1).AutoFit
Application.ScreenUpdating = True
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
End Sub
Not sure it is what I need now - due to errors, but: Is there a better way?;
The error is occuring 8 out of 10 times (My Inbox contains 80 unique e-mails). Can anyone
spot a problem in the code for me. Thanks very much for any assitance. Also, Version 2003 of both Outlook and Excel are in use here.
Jim
Sub SingleRequest() 'Populate requested Store Number with Current Outlook e-mail for same
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim Subj As String
Dim recTime As Date
Dim stBody As String
Dim StNum As String
Dim LineBreak As Long
Dim i As Long
Dim ctr As Long
Application.ScreenUpdating = False
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Folders("Personal Folders-Jim").Folders("Inbox").Folders("StopIn")
ActiveSheet.Range("A1:B200").ClearContents
ctr = 0
For Each olMail In Fldr.Items
Subj = olMail.Subject
StNum = ExtractNum(olMail.Subject)
If StNum = Range("C1").Value Then
recTime = olMail.ReceivedTime
ctr = ctr + 1
With ActiveSheet
.Cells(1, 1).Value = Subj
.Cells(1, 2).Value = recTime
.Columns(2).AutoFit
End With
stBody = olMail.Body
LineBreak = 1
i = 3
Do ' Getting R/T error Invalid Procedure call or argument (on Next line)
ActiveSheet.Cells(i, 1).Value = _
Mid(stBody, LineBreak, InStr(LineBreak, stBody, Chr(10)) - LineBreak)
LineBreak = InStr(LineBreak + 1, stBody, Chr(10)) + 1
i = i + 1
Loop Until LineBreak = 0 Or LineBreak > Len(stBody)
Exit Sub 'Quit Macro
End If
Next olMail
If ctr = 0 Then
MsgBox Range("D1").Value & " has not reported in today - " & Format(Date, "mmmm dd, yyyy")
End If
ActiveSheet.Columns(1).AutoFit
Application.ScreenUpdating = True
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
End Sub