J
Junoon
Hi,
I have a worksheet in which i extract email IDs from Outlook, of people
opting for a drop time.
I send out a voting response mail & the responses are collected into a
custom folder "DropTime" created below Inbox.
The code uses "Find" to search for Voting responses (in Subject)
formatted as text, like 0:30;1:00;1:30 etc...in the DropTime folder &
extracts the SenderName & puts them under the respective columns.
The Header columns in the Worksheet are the same text
0:00;0:30;1:00;1:30 etc....
A B C D E
F
0:00 0:30 1:00 1:30 2:00
2:30
-------------------------------------------------------------------------------
John Sam Masey Shirley
Fabian Dolly Manoj Raul
Gatsy
Hurley
etc,......
The only problem with the following code is that it only processes some
of the mails & not all (Dont know why). So i have to run the code again
& again to process them, which is tiresome as there are around 200-250
mails. I think i need to use FindNext to process the remaining mails,
but donot know how to get it in the loop.
========================
Function CreateInboxFolder(oInbox, Fldr) As Object
Dim oFold As Object
'Look for archive folder and create if doesn't exist, create it
On Error Resume Next 'ignore error
Set oFold = oInbox.Folders(Fldr)
If Err.Number <> 0 Then Err.Clear
If oFold Is Nothing Then
Set oFold = oInbox.Folders.Add(Fldr, olFolderInbox)
End If
Set CreateInboxFolder = oFold
End Function
Function GetOutlook() As Object
Dim olApp As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not running: please open the application first"
End If
Set GetOutlook = olApp
End Function
Sub GetDropTimeVotes()
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Dim objMail As Outlook.MailItem
Dim objItem As Object
Dim olApp As Outlook.Application
If olApp Is Nothing Then
Set olApp = GetOutlook()
End If
Dim objWks As Excel.Worksheet
Dim objTimeRange As Excel.Range, objRange As Excel.Range
Dim iRow
Dim FolderName As Object
On Error Resume Next
Set objNS = olApp.GetNamespace("MAPI")
Set objInbox =
objNS.GetDefaultFolder(olFolderInbox).Folders("DropTime")
Set objWks = ThisWorkbook.Worksheets("Drops") 'Use default Sheet1
With objWks
iRow = objWks.Cells(objWks.Rows.Count, 1).End(xlUp).Row + 1
End With
Set objTimeRange = objWks.UsedRange
For Each objItem In objInbox.Items
If objItem.Class = olMail Then
Set objMail = objItem
If objItem.VotingResponse <> "" Then
Set objRange =
objTimeRange.Find(objMail.VotingResponse, , , xlWhole)
If Not objRange Is Nothing Then
objWks.Cells(iRow, objRange.Column).Value =
objMail.SenderName
End If
Set FolderName = CreateInboxFolder(objInbox, "DropTime"
& "-" & Date)
objMail.Move FolderName
iRow = iRow + 1
End If
End If
Next
Set objItem = Nothing
Set objRange = Nothing
Set objTimeRange = Nothing
Set objMail = Nothing
Set objWks = Nothing
Set objExcel = Nothing
Set objNS = Nothing
Set objInbox = Nothing
Set olApp = Nothing
End Sub
========================================
Is there a way to process them in one go......???
Rgds,
Junoon
I have a worksheet in which i extract email IDs from Outlook, of people
opting for a drop time.
I send out a voting response mail & the responses are collected into a
custom folder "DropTime" created below Inbox.
The code uses "Find" to search for Voting responses (in Subject)
formatted as text, like 0:30;1:00;1:30 etc...in the DropTime folder &
extracts the SenderName & puts them under the respective columns.
The Header columns in the Worksheet are the same text
0:00;0:30;1:00;1:30 etc....
A B C D E
F
0:00 0:30 1:00 1:30 2:00
2:30
-------------------------------------------------------------------------------
John Sam Masey Shirley
Fabian Dolly Manoj Raul
Gatsy
Hurley
etc,......
The only problem with the following code is that it only processes some
of the mails & not all (Dont know why). So i have to run the code again
& again to process them, which is tiresome as there are around 200-250
mails. I think i need to use FindNext to process the remaining mails,
but donot know how to get it in the loop.
========================
Function CreateInboxFolder(oInbox, Fldr) As Object
Dim oFold As Object
'Look for archive folder and create if doesn't exist, create it
On Error Resume Next 'ignore error
Set oFold = oInbox.Folders(Fldr)
If Err.Number <> 0 Then Err.Clear
If oFold Is Nothing Then
Set oFold = oInbox.Folders.Add(Fldr, olFolderInbox)
End If
Set CreateInboxFolder = oFold
End Function
Function GetOutlook() As Object
Dim olApp As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not running: please open the application first"
End If
Set GetOutlook = olApp
End Function
Sub GetDropTimeVotes()
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Dim objMail As Outlook.MailItem
Dim objItem As Object
Dim olApp As Outlook.Application
If olApp Is Nothing Then
Set olApp = GetOutlook()
End If
Dim objWks As Excel.Worksheet
Dim objTimeRange As Excel.Range, objRange As Excel.Range
Dim iRow
Dim FolderName As Object
On Error Resume Next
Set objNS = olApp.GetNamespace("MAPI")
Set objInbox =
objNS.GetDefaultFolder(olFolderInbox).Folders("DropTime")
Set objWks = ThisWorkbook.Worksheets("Drops") 'Use default Sheet1
With objWks
iRow = objWks.Cells(objWks.Rows.Count, 1).End(xlUp).Row + 1
End With
Set objTimeRange = objWks.UsedRange
For Each objItem In objInbox.Items
If objItem.Class = olMail Then
Set objMail = objItem
If objItem.VotingResponse <> "" Then
Set objRange =
objTimeRange.Find(objMail.VotingResponse, , , xlWhole)
If Not objRange Is Nothing Then
objWks.Cells(iRow, objRange.Column).Value =
objMail.SenderName
End If
Set FolderName = CreateInboxFolder(objInbox, "DropTime"
& "-" & Date)
objMail.Move FolderName
iRow = iRow + 1
End If
End If
Next
Set objItem = Nothing
Set objRange = Nothing
Set objTimeRange = Nothing
Set objMail = Nothing
Set objWks = Nothing
Set objExcel = Nothing
Set objNS = Nothing
Set objInbox = Nothing
Set olApp = Nothing
End Sub
========================================
Is there a way to process them in one go......???
Rgds,
Junoon