Outlook to excel using macros - vba

My query is , i have below vba code trying to extract the outlook contents of a Particular Date - but my issue is whenever i try to run this code all the emails irrespective of the my required dates are being extracted:-
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Object
Dim i As Integer
Dim Dstr As Date
Dim itms As Outlook.Items
Dim filteredItms As Outlook.Items
On Error GoTo err
dStart = Application.InputBox("Enter you start date in MM/DD/YYYY")
If dStart = Empty Then
MsgBox "Start date cannot be empty, please run it again"
Exit Sub
End If
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Application.ActiveExplorer.CurrentFolder
MsgBox Fldr
i = 2
Do
For Each olMail In Fldr.Items
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)
err:
'Display the error message in Status bar
If err.Number > 0 Then
Application.StatusBar = err.Description
MsgBox "Err#" & err.Number & " " & err.Description
End If
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub

I have noticed the following code:
Do
For Each olMail In Fldr.Items
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)
The fact is that the Do loop is ignored and you iterate over all items in the folder using the following loop inside:
For Each olMail In Fldr.Items
You need to use the Find/FindNext or Restrict methods of the Items class instead. The following articles describe them in depth:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder

Remove the Do Loop and inside the For Loop and another outer If/then statement conditioned to your date specification:
For Each olMail In Fldr.Items
If (DateValue(olMail.ReceivedTime) = dStart) Then
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
End If
Next olMail

Related

Search for sent items with today's date and specific subject

I want when Outlook opens to:
Search sent items with today's date with a specific subject.
If none is found, then send the "Test" email.
If found, display messagebox that says "Email is found".
I have only been able to do #1.
Private Sub Application_Startup()
Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
MItem.Subject = "Test Alert"
MItem.To = "email#abc.com"
MItem.DeferredDeliveryTime = DateAdd("n", 1, Now) 'n = minute, h=hour
MItem.Send
End Sub
Update:
This is what I've tried. It doesn't seem to be searching the Sent Items folder with the subject.
Public Function is_email_sent()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.Folder
Dim olItms As Outlook.Items
Dim objItem As Outlook.MailItem
On Error Resume Next
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(Outlook.olFolderSentMail)
For Each objItem In olFldr.Items
If objItem.Subject = "Test Alert" And _
objItem.SentOn = Date Then _
MsgBox "Yes. Email found"
Else
MsgBox "No. Email not found"
Exit For
End If
Next objItem
End Function
The main error is misuse of On Error Resume Next. Errors are bypassed, not fixed.
Public Sub is_email_sentFIX()
Dim olFldr As Folder
Dim olItms As Items
Dim objItem As Object
Dim bFound As Boolean
' Not useful here.
' Use for specific purpose to bypass **expected** errors.
'On Error Resume Next
Set olFldr = Session.GetDefaultFolder(olFolderSentMail)
Set olItms = olFldr.Items
olItms.sort "[SentOn]", True
For Each objItem In olItms
If objItem.Class = OlMail Then
Debug.Print objItem.Subject
If objItem.Subject = "Test Alert" Then
Debug.Print objItem.SentOn
Debug.Print Date
If objItem.SentOn > Date Then
MsgBox "Yes. Email found"
bFound = True
Exit For
End If
End If
End If
Next objItem
If bFound = False Then
MsgBox "No. Email not found"
End If
End Sub
If there are an excessive number of items in the Sent folder the "not found" outcome will be slow.
One possible option to the brute force way is to Restrict to the specific item, rather than using If statements.
this is some code ive used;
Sub sendmail10101() 'this is to send the email from contents in a cell
Dim obApp As Object
Dim NewMail As MailItem
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'You can change the concrete info as per your needs
With NewMail
.Subject = Cells(21, 3).Value
.To = Cells(18, 3).Value
.Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
'.Attachments.Add ("C:\Attachments\Test File.docx")
.Importance = olImportanceHigh
.Display
End With
Set obApp = Nothing
Set NewMail = Nothing
End Sub
the next part is to search the mail box, which you can also use to search from the first initial cell;
Option Explicit
Public Sub Search_Outlook_Emails()
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outStartFolder As Outlook.MAPIFolder
Dim foundEmail As Outlook.MailItem
Set outApp = New Outlook.Application
Set outNs = outApp.GetNamespace("MAPI")
'Start at Inbox's parent folder
Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent
'Or start at folder selected by user
'Set outStartFolder = outNs.PickFolder
If Not outStartFolder Is Nothing Then
Set foundEmail = Find_Email_In_Folder(outStartFolder, ThisWorkbook.Sheets("Dashboard").TextBox1.Value)
If Not foundEmail Is Nothing Then
If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
"Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
"Open the email?", vbYesNo, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' found") = vbYes Then
foundEmail.Display
End If
Else
MsgBox "", vbOKOnly, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' not found"
End If
End If
End Sub
Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem
Dim outItem As Object
Dim outMail As Outlook.MailItem
Dim outSubFolder As Outlook.MAPIFolder
Dim i As Long
Debug.Print outFolder.FolderPath
Set Find_Email_In_Folder = Nothing
'Search emails in this folder
i = 1
While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing
Set outItem = outFolder.Items(i)
If outItem.Class = Outlook.OlObjectClass.olMail Then
'Does the findText occur in this email's body text?
Set outMail = outItem
If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail
End If
i = i + 1
Wend
DoEvents
'If not found, search emails in subfolders
i = 1
While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing
Set outSubFolder = outFolder.Folders(i)
'Only check mail item folders
If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)
i = i + 1
Wend
End Function
the previous code brings us a message box to say if its been found which can be removed but maybe use the message box and an IF statement
such as;
with activeworkbook
if msgbox.value = "yes" then
range("A1:A30") = "COMPLETED" 'ASSUMING THIS IS THE INTIAL TEST RANGE IT WILL CHANGE THE SUBJECT THUS STOPPING THE FIRST MACRO
end if
end with
or if no message box then use something such as IF found then so on...
hope this helps

Get mail info into Excel using Outlook VBA

I'm trying to extract information from unread e-mails in a specific folder and paste it in a structured Excel file.
I need the subject, the body, the sender, received time, conversation ID and the attachment names.
Important: it has to be an Outlook macro and not an Excel macro.
I have the following code but it is giving me
"runtime error '9': subscript out of range.
Sub WriteTextFile()
Dim wkb As Workbook
Set wkb = Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set Workbook = objExcel.Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim row As Integer
row = 2
objExcel.Worksheets("Sheet1").Cells(1, 1).Value = "Sender"
objExcel.Worksheets("Sheet1").Cells(1, 2).Value = "Subject"
objExcel.Worksheets("Sheet1").Cells(1, 3).Value = "Date"
objExcel.Worksheets("Sheet1").Cells(1, 4).Value = "ID"
objExcel.Worksheets("Sheet1").Cells(1, 5).Value = "Body"
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetLast
Set objFolder = objFolder.Folders("Deleted Items")
For Each item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = item.sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = item.Body
Next
Workbook.Save
Workbook.Saved = True
Workbook.Close
objExcel.Quit
Set Workbook = Nothing
Set objExcel = Nothing
End Sub
According to test your code, you could try to add row = row+1 and use this method to get Delete Items:
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
For Each Item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = Item.Sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = Item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = Item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = Item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = Item.Body
row = row + 1
Next

Send Automatic Email for loop

I have a code:
Sub sendEmail()
Dim OutlookApp As Object
Dim OutlookItem As Object
Dim i As Integer
Dim Address As String
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookItem = OutlookApp.CreateItem(0)
With OutlookItem
For i = 4 To 15
If Cells(i, 18) <= Cells(i, 6) Then
Address = Cells(i, 14).Value
Set OutlookApp = CreateObject("Outlook.application")
Set OutlookItem = OutlookApp.CreateItem(0)
.To = Address
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & Cells(i, 4) & "is due on " & Cells(i, 9)
.Send
Set OutlookItem = Nothing
Set OutlookApp = Nothing
'Application.Wait (Now + #12:00:08 AM#)
ElseIf Cells(i, 18) > Cells(i, 15) Then
Exit Sub
ElseIf Cells(i, 18) = "" And Cells(i, 15) = "" Then
Exit Sub
End If
Next i
End With
End Sub
It does send only first email then it prompts me with run-time error saying :
The item has been moved or deleted
And debugger highlights the " .To = Address" line.
When I use .Display instead of send it works.
Any ideas?
Re-creating the Outlook application object in every loop iteration does not make sense. It's equivalent to killing Outlook and re-starting it for every mail you send. Let's not do that.
First, set a reference to the "Microsoft Outlook 15.0 Object Library" in your Excel VBA project (or whatever version you happen to have installed).
Now you can create an Outlook object directly with New and it also enables the autocompletion and all the Outlook-specific constants, like olMailItem.
Now your code can be condensed to something like this:
Sub sendEmail()
Dim OutlookApp As New Outlook.Application
Dim r As Range
For Each r In ActiveSheet.Range("4:15").Rows
If r.Cells(18) <= r.Cells(6) And r.Cells(18) > "" And r.Cells(15) > "" Then
With OutlookApp.CreateItem(olMailItem)
.To = r.Cells(14)
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & r.Cells(4) & " is due on " & r.Cells(9)
.Send
End With
End If
Next r
OutlookApp.Quit
Set OutlookApp = Nothing
End Sub

Adding multiple CC in Outlook Mail

I have this line of code I've tried to add multiple CC's in the Outlook Mail. But it only returns ;. I have found this sample at MSDN.
Dim ccMail as String
Dim ccRow as Long
Dim objMail as Object
ccRow = Cells(Rows.count, 16).End(xlUp).Row
With objMail
.Subject = Sheet1.TextBox1.Value
For k = 4 To ccRow
ccMail = ccMail & ";" & Cells(k, 1).Value
Next k
.cc = ccMail
end with
All of the CC Recipients is found in column P.
Any help?Thanks.
You used With objMail but did not specify Worksheet for Cells(k, 1).Value. This is likely to result in an error.
In addition, I presume you want to refer to ws.Cells(k, 16) instead since what you want is column P.
Here is an Example on how to loop using Do-Until Loops to get cell Values.
Option Explicit
Sub Example()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim iRow As Long
Dim Recip As String
Dim Sht As Worksheet
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
Set Sht = ActiveWorkbook.Sheets("Sheet1")
With Sht
With olMail
Do Until IsEmpty(Cells(iRow, 16))
Recip = Cells(iRow, 16).Value
Set olRecip = .Recipients.Add(Recip)
olRecip.Type olCC
olRecip.Resolve
iRow = iRow + 1
Loop
.Subject = "Subject"
.Body = "Hi " & .Body
.Display
End With
End With
Set olApp = Nothing
End Sub
Do-Until loop and IsEmpty

separting outlook subject line into columns

I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.
Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject
Next
End Sub
My data is in the below format
SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)
So in total 7 columns I plan to leave is below.
Sender
Location
LOB
Date
Shift End Time
Shift Leave Time
Leave Type
In it's current state as you can see it only produces two columns and I do not know how to break the subject line apart.
Any help will be most appreciated.
Thanks
Use Split.
Sub subject2excel()
Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object
Dim Words() As String
'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myFolder.Items.count
Set myitem = myFolder.Items(i)
If TypeOf myitem Is MailItem Then
'msgText = myitem.body
xlobj.Range("a" & i + 1).Value = myitem.Sender
'xlobj.Range("b" & i + 1).Value = myitem.Subject
Words = Split(myitem.Subject, " | ")
For j = 0 To UBound(Words)
Debug.Print Words(j)
Next j
End If
Next i
exitRoutine:
Set myOlApp = Nothing
Set myFolder = Nothing
Set xlobj = Nothing
Set myitem = Nothing
End Sub
I was able to solve the issue
Sub subject2excel()
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
Dim vSubject As Variant
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0 'err_Handler
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set Heading
With xlWB.Sheets(1)
.Range("A" & 1).Value = "Sender"
.Range("B" & 1).Value = "Location"
.Range("C" & 1).Value = "LOB"
.Range("D" & 1).Value = "Date"
.Range("E" & 1).Value = "Shift End Time"
.Range("F" & 1).Value = "Requested Leave Time"
.Range("G" & 1).Value = "Paid/Unpaid"
End With
'Fill sheet
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For i = 1 To olFolder.Items.Count
Set olItem = olFolder.Items(i)
If InStr(1, olItem.Subject, "|") > 0 Then
vSubject = Split(olItem.Subject, "|")
With xlWB.Sheets(1)
.Range("A" & i + 1).Value = olItem.Sender
.Range("B" & i + 1).Value = vSubject(0)
.Range("C" & i + 1).Value = vSubject(1)
.Range("D" & i + 1).Value = vSubject(2)
.Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
.Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
.Range("F" & i + 1).HorizontalAlignment = -4152 'align right
.Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
End With
End If
Next i
xlWB.Sheets(1).UsedRange.Columns.Autofit
exitRoutine:
Set olFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub