I have a macro that will get all emails that contains "HAPPY", "NEUTRAL" and "SAD" in the subject and copy it to a new sheet of the workbook. I want to add functionality to only display mood based on the date defined by a user.
Also, code below read emails in the inbox. I need it to read all the folders in my mailbox (e.g. Outbox and subfolders).
Sub GetMood()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
Dim ws As Worksheet
Dim iRow As Variant
Dim d As Date
x = 2
d = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, "HAPPY") > 0) Then
ThisWorkbook.Sheets("Report").Cells(1, 1) = "Sender"
ThisWorkbook.Sheets("Report").Cells(1, 2) = "Mood"
ThisWorkbook.Sheets("Report").Cells(1, 3) = "Date"
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "NEUTRAL") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "SAD") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
'MsgBox "Report Generated", vbOKOnly
'Else
'olMail.Display
Exit For
End If
Next
End Sub
Private Sub Workbook_Open()
Worksheets("StartSheet").Activate
End Sub
This will look into every folders in Outlook and gather the information in mInfo to create a list in sheet Report.
I've modified the structure so that it'll detect if Outlook is already open, add a column with the detected mood and improve performances! ;)
Sub GetMood()
Dim wS As Excel.Worksheet
Dim outlookApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
'Dim sir() As String
'Dim iRow As Variant
'Dim d As Date
Dim RgPaste As Excel.Range
Dim mSubj As String
Dim mInfo() As Variant
Dim nbInfos As Integer
ReDim mInfo(1 To 1, 1 To 3)
nbInfos = UBound(mInfo, 2)
'd = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set wS = ThisWorkbook.Sheets("Report")
With wS
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Mood"
.Cells(1, 3) = "Date"
Set RgPaste = .Cells(2, 1)
End With 'wS
Set outlookApp = GetObject(, "Outlook.Application")
If outlookApp Is Nothing Then Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
For Each Fldr In olNs.Folders
For Each olMail In Fldr.Items
With olMail
mSubj = .Subject
mInfo(1, 1) = .SenderName
mInfo(1, 2) = mSubj
mInfo(1, 3) = .ReceivedTime
'.Display
End With 'olMail
With RgPaste
If (InStr(1, mSubj, "HAPPY") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "HAPPY"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "NEUTRAL") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "NEUTRAL"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "SAD") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "SAD"
Set RgPaste = .Offset(1, 0)
End If
End With 'RgPaste
Next olMail
Next Fldr
'MsgBox "Report Generated", vbOKOnly
End Sub
Related
I'm trying to access calendar entries from 2 custom Outlook calendars using Excel VBA.
I've obtained some code which gives me what I want from the default calendar but I cannot see how to change the location to my own calendars.
The code I'm using is
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim nextrow As Long
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate("30/11/2021")
ToDate = CDate("20/12/2021")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = 2
With Sheets("Cal-Ext")
.Range("A1:E1").Value = Array("Date", "Start Time", "End Time", "Subject", "Location")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = nextrow + 5
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
.Columns.AutoFit
End With
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
I need to change the set olfolder command before the second loop to select my own calendar but nothing I've tried works.
Outlook calendar
Current excel result
Here is a quick code that I wrote to loop through all the navigation folders of My Calendars
This code was tested in MS Outlook. You may have to edit it for it to work in MS Excel.
Option Explicit
Sub Sample()
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = Outlook.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
Screenshot
Code from Excel
Option Explicit
Sub ListAppointments()
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = OutApp.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
I am trying to import Outlook email data with VBA, and succeeded with this code:
Sub getMail()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As items
Dim olMailItem As MailItem
Dim objRept As ReportItem
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder
Set olItems = olInboxFolder.items
Set olReportItem = olInboxFolder.items
Dim items, objects As Variant
items = Array(olMailItem, olReportItem)
objects = Array(MailItem, ReportItem)
i = 1
ThisWorkbook.Worksheets(2).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
For Each olMailItem In olItems
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets(2).Cells(i + 1, "D").Value = olItems(i).Body
i = i + 1
Next olMailItem
ThisWorkbook.Worksheets(2).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
This code imports only the mail items. Undelivered emails are known as reportitems and I am not able to make it work.
Your loop is using olMailItem which you have declared as a MailItem. Also, you are not going to be able to use ".SenderEmailAddress" on report items.
Try the following:
Sub getMail()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As items
Dim olItem As Variant
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder
Set olItems = olInboxFolder.items
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
ThisWorkbook.Worksheets(2).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
i = 1
For Each olItem In olItems
' MailItem
If olItem.Class = olMail Then
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets(2).Cells(i + 1, "D").Value = olItems(i).Body
' ReportItem
ElseIf olItem.Class = olReport Then
ThisWorkbook.Worksheets(2).Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets(2).Cells(i + 1, "B").Value = _
olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E") ' PR_SENDER_EMAIL_ADDRESS
ThisWorkbook.Worksheets(2).Cells(i + 1, "C").Value = olItems(i).Subject
End If
i = i + 1
Next olItem
ThisWorkbook.Worksheets(2).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
I am trying to make appointments from a given date.
To avoid duplicates I tried coloring the cells but that does not seem viable.
Now I am trying to check if an appointment with the same "subject" as the cell exists and if so go to the next line.
I get the error
Object required
Private Sub Workbook_Open()
Set myOutlook = CreateObject("Outlook.Application")
r = 2
Do Until Trim(Cells(r, 8).Value) = ""
If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then
r = r + 1
Else
Set myapt = myOutlook.createitem(1)
myapt.Subject = Cells(r, 9).Value
myapt.Start = Cells(r, 8).Value
myapt.AllDayEvent = True
myapt.BusyStatus = 5
myapt.ReminderSet = True
'myapt.Body = ""
myapt.Save
Cells(r, 8).Interior.ColorIndex = 4
r = r + 1
End If
Loop
End Sub
To check if an item exists you need to filter the existing items:
Option Explicit
Public Sub CreateItemsIfNotExist()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 2
Do Until Trim$(ws.Cells(iRow, 8).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 9).Value
.Start = ws.Cells(iRow, 8).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 8).Interior.ColorIndex = 4
End If
iRow = iRow + 1
Loop
End Sub
Note that maybe you want to quit outlook in the end olApp.Quit.
I am trying to import dates in column "E" to my Outlook calendar.
I have code started, but it is only adding certain dates to my calendar and not adding what it seems to me like multiple dates for ex. The date of 6/2 is being added to my calendar with correct subject date and body, but for dates for 6/1 I have an empty slot.
Option Explicit
Public Sub CreateOutlookApptz()
Sheets("Sheet2").Select
On Error GoTo Err_Execute
Dim olApp As OUtlook.Application
Dim olAppt As OUtlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As OUtlook.Namespace
Dim CalFolder As OUtlook.MAPIFolder
Dim subFolder As OUtlook.MAPIFolder
Dim arrCal As String
Dim i As Long
On Error Resume Next
Set olApp = OUtlook.Application
If olApp Is Nothing Then
Set olApp = OUtlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
Set subFolder = CalFolder
Set olAppt = subFolder.Items.Add(olAppointmentItem)
MsgBox Cells(i, 6) + Cells(i, 7)
'MsgBox subFolder, vbOKCancel, "Folder Name"
With olAppt
'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7)
.End = Cells(i, 8) + Cells(i, 9)
.Subject = Cells(i, 2)
.Location = Cells(i, 3)
.Body = Cells(i, 4)
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = True
.Categories = Cells(i, 5)
.Save
End With
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub
Try it this way.
Private Sub Add_Appointments_To_Outlook_Calendar()
'Include Microsoft Outlook nn.nn Object Library from Tools -> References
Dim oAppt As AppointmentItem
Dim Remind_Time As Double
i = 2
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
'Loop through entire list of Reminders to be added
While Subj <> ""
Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
oAppt.Subject = Subj
oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
oAppt.ReminderMinutesBeforeStart = Remind_Time
oAppt.AllDayEvent = True
oAppt.Save
i = i + 1
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
Wend
MsgBox "Reminder(s) Added To Outlook Calendar"
End Sub
Your setup will look something like this.
I talk about this concept, and many other similar, but different, things in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC?ie=UTF8&keywords=ryan%20shuell&qid=1464361126&ref_=sr_1_1&sr=8-1
I'm not an expert in VBA, got an error which I can't figure out, can you please help advise?
I need an excel macro to copy from all the emails in a folder to my excel, googled and found the below code. The code runs fine for some emails, after that there will be a runtime error 440: array index out of bounds at this line.
abody = Split(objfolder.Items(i).Body, vbNewLine)
Most of the time I just record macro and edit from there so I don't really understand what is array index out of bounds.
Really hope you can enlighten me, thank you so much in advance for your help... =)
Full code can be found below...
Added in the part where the macro will get the details of the email it's processing... But what is baffling me is the received details of the email does not match the body. Can anyone please help advise?
Sub test()
Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")
Cnt = 0
For Each olMail In olFldr.Items
On Error GoTo errorhandler
Cnt = Cnt + 1
abody = Split(olFldr.Items(Cnt).Body, vbNewLine)
For j = 0 To UBound(abody)
Sheet1.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next
ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
Cells(1, 1).Value = arrData(1, Cnt)
Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
olFldr.Items(Cnt).Move olNS.GetDefaultFolder(6).Folders("Processed")
Next
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
errorhandler:
Application.CutCopyMode = False
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
Exit Sub
End Sub
updated code:
Sub test()
Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant
Dim ws As Worksheet
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")
Set ws = ThisWorkbook.Sheets("Sheet1")
EmailCount = olFldr.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Cnt = 1
For Each olMail In olFldr.Items
abody = Split(olMail.Body, vbNewLine)
For j = 0 To UBound(abody)
ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next
ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
ws.Cells(1, 1).Value = arrData(1, Cnt)
ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
olMail.Move olNS.GetDefaultFolder(6).Folders("Processed")
Cnt = Cnt + 1
Next
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub
Can you try to change your looping part to this.
Also add the declaration and variable assignment for the target Worksheet.
Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'added this to avoid the subscript out of range
Cnt = 1
For Each olMail In olFldr.Items
On Error GoTo errorhandler
abody = Split(olMail.Body, vbNewLine) 'changed this to olMail.Body since you are already iterating each mail
For j = 0 To UBound(abody)
ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j) 'use the declared ws here
Next
ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
ws.Cells(1, 1).Value = arrData(1, Cnt) 'use ws here as well if same Sheet1
ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
olMail.Move olNS.GetDefaultFolder(6).Folders("Processed") 'change to olMail as well
Cnt = Cnt + 1
Next
This is untested so i leave the testing to you. :)