First off, I'm new to VBA, with about 20 hours of training.
I'm trying to export items from Outlook 2010 to Excel 2010. I want to grab all the unfinished "To Do" items from Outlook and throw them into Excel with one item per row, and columns for item parameters (like Subject, Due Date, attachments, etc.).
Here's the first pass that actually does what I explained, and imports only tasks (tasks are a subset of all to do items, from what I understand) and their Subject/Due Date:
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function
Sub getOlTasks()
Dim olApp As Object ' Outlook.Application
Dim olnameSpace As Object ' Outlook.Namespace
Dim taskFolder As Object ' Outlook.MAPIFolder
Dim tasks As Object ' Outlook.Items
Dim tsk As Object
Set olApp = GetOutlookApp
Set olnameSpace = olApp.GetNamespace("MAPI")
Set taskFolder = olnameSpace.GetDefaultFolder(13) 'olFolderTasks is folder# 13, apparently
Set tasks = taskFolder.Items
For x = 1 To tasks.Count
Set tsk = tasks.Item(x)
Sheet1.Cells(1, 1).Activate
Do While IsEmpty(ActiveCell) = False
Selection.Offset(1, 0).Activate
Loop
'Fill in Data
If Not tsk.Complete Then
ActiveCell.Value = tsk.Subject
Selection.Offset(0, 1).Activate
ActiveCell.Value = tsk.DueDate
Selection.Offset(1, -1).Activate
End If
Next x
End Sub
I tried to do this with only "tasks" items, everything was going smoothly until I realized that tasks can't have attachments. When I have an email w/attachment that I turn into a task, I lose the attachment. Apparently what I need to do is import all "To Do items", rather than just tasks.
So My questions are:
1) What folder number is olFolderToDo? I have seen people run code like:
Set taskFolder = olnameSpace.GetDefaultFolder(olFolderTasks) 'rather than GetDefaultFolder(13)
which would lead me to believe I should be able to just use olFolderToDo, but when I try to use the name of the folder in my first example rather than the number, I get an invalid argument runtime error. If anyone knows why, I'd be interested to know.
2) How would I go about importing an attachment from an email to a specific cell in excel?
See OlDefaultFolders Enumeration (Outlook)
Name Value Description
olFolderToDo 28 The To Do folder.
Related
I frequently have to send out emails to various contractors to check in on the statuses of the projects I have bid with them. Currently I have to enter the name of each Rep in reference cell and then execute the macro but I deal with dozens of reps. I would like to be able to send an bulk email blast out to all the reps whose projects are still "Open" with one macro instead of having to change the reps name each time. Also, I tried to use the automatic .send function but cannot get it to work and I would hope to not have to keep using the .display for this situation for obvious reasons.
Sub EmailGCs_1()
'Declare Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
'Declare Word Variables
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim oWrdTble As Word.Table
'Declare Excel Variables
Dim ExcTbl As ListObject
On Error Resume Next
'Get The Active instance of Outlook, if there is one.
Set oLookApp = GetObject(, "Outlook. Application")
'If ther is no active instance create one
If Err.Number = 429 Then
'Create a new instance
Set oLookApp = New Outlook.Application
End If
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
'Create a refernce to the table
Set Exltbl = ActiveSheet.ListOjects(1)
With oLookItm
'Basic Info
.To = Range("D2").Value
.Subject = "Various Project Statuses"
'Display Email
.Display
'Get The Inspector
Set oLookIns = .GetInspector
'Get the Word Editor
Set oWrdDoc = oLookIns.WordEditor
'Filter Table to Distro
ActiveSheet.Range("Table1").AutoFilter field:=6, Criteria1:=Cells(1, 6).Value
'Hide Columns
Range("G:R").EntireColumn.Hidden = True
'Copy Items
Worksheets(1).ListObjects("Table1").Range.Copy
oWrdDoc.Range(1, 2).Paste
'Greeting Text
MsgText = Split(Range("F1").Value, " ")(0) & "," & vbNewLine & "Can you please let me know the statuses of the projects below." & vbNewLine
oWrdDoc.Range.InsertBefore Text:=MsgText
'Clearing out filter and selection
ActiveSheet.ListObjects(1).AutoFilter.ShowAllData
Application.CutCopyMode = False
Range("G:R").EntireColumn.Hidden = False
End With
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
End Sub
The Send method is not safe and the Outlook object model may trigger security prompts or give errors when Outlook is automated from an external application. Possible workarounds are listed below:
Create a COM add-in which deals with a safe Application instance which doesn't trigger security prompts.
Use a low-level code on which Outlook is built on and which doesn't have security riggers onboard. Or may also consider any other third-party wrappers around that API, for example, Redemption.
Use a third-party components for suppressing Outlook security warnings. See Security Manager for Microsoft Outlook for more information.
Use group policy objects for setting up machines.
Install any AV software with latest updates.
Here is one way to loop through a list.
Source: Sending Email to a List of Recipients Using Excel and Outlook
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub EmailGCs_2()
' Early binding requires reference to Microsoft Outlook XX.X Object Library
' Declare Outlook variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim iCounter As Long
'Application.ScreenUpdating = False
'There can only be one instance of Outlook
' GetObject is not needed.
' The problematic On Error Resume Next can be dropped
Set oLookApp = New Outlook.Application
'Subsequent errors would have been bypassed
' due to the missing On Error GoTo 0
'If there are any errors you can fix them now.
'Assumes a list of email addresses in column D starting at cell D2
' https://learn.microsoft.com/en-us/office/vba/excel/concepts/working-with-other-applications/sending-email-to-a-list-of-recipients-using-excel-and-outlook
'Debug.Print WorksheetFunction.CountA(Columns(4)) + 1
For iCounter = 2 To WorksheetFunction.CountA(Columns(4)) + 1
'Debug.Print iCounter
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
With oLookItm
'Basic Info
.To = Cells(iCounter, 4).Value
.Subject = "Various Project Statuses"
'Display Email
.Display
End With
Set oLookItm = Nothing
Next
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub
I need an excel file to email an exported chart to a varying number of contacts on open. For every email, the chart needs to be refiltered. I figured out how to do this by creating a dynamic chart with a scrollbar and on each iteration of the loop I will at 13 to its position (p).
How do I get my VBA code to send an email with the exported chart to whatever is in column 2? It also is currently only sending one email, rather than however many are in the column. Any help would be awesome.
Private Sub Workbook_Open()
Dim b1 As Workbook, b2 As Workbook
Dim sh As Worksheet
Set b1 = ThisWorkbook
Dim olApp As Object
Dim olMail As Object
Dim i As Long
Dim p As Integer
Dim email As Range
Dim book As Range
Set olApp = CreateObject("Outlook.application")
Set olMail = olApp.createitem(i)
Set book = Range("A1:B9")
p = 1
'START LOOP
For Each email In book.Rows
Sheets("nothing").Range("B1").Select
ActiveCell.FormulaR1C1 = p
Worksheets(1).ChartObjects(1).Activate
ActiveChart.Export "testchartlocation.png"
With olMail
.To = "test#email.com"
.Subject = "Emailer Testing..."
.HTMLbody = "<html><p>Testing...</p><img src='testchartlocation.png'>"
.display
End With
p = p + 13
Application.Wait (Now + TimeValue("0:00:01"))
Next
'END LOOP
'ThisWorkbook.Close False
End Sub
If by
How do I get my VBA code to send an email with the exported chart to
whatever is in column 2?
You mean you have email addresses stored in column 2 that you need to access with each iteration to send the exported chart to, you could change this line
.To = "test#email.com"
To
.To = Cells(email.Row, 2) '<-Make sure to qualify this range with whatever worksheet you're pulling from
Concerning your issue with your email only being generated once, you need to move
Set olMail = olApp.createitem(i) '<- you can change `i` to `0`
Into the beginning of your For-Next loop and set it = Nothing at the end like
For Each email In book.Rows
Set olMail = olApp.createitem(0)
'Do Stuff
Set olMail = Nothing
Next email
That way a new email is generated every iteration.
EDIT:
You can probably get rid of this line
Sheets("nothing").Range("B1").Select
And replace
ActiveCell.FormulaR1C1 = p
With
Sheets("nothing").Range("B1").FormulaR1C1 = p
Since you're working with multiple sheets and .Activate functions, I would recommend qualifying all of your ranges.
I am trying to update a shared calendar from an Excel sheet. The code works for the owner of this shared calendar, but it fails for me. The calendar was shared to me and I have full owner permissions.
I can edit the calendar manually, but the idea is that anyone will be able run the macro from this Excel sheet to update the shared calendar.
The relevant code, up to the failure point:
Sub UpdateSched()
Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olFldrOwner As Outlook.Recipient
On Error Resume Next
' check if Outlook is running
Set olApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFldrOwner = olNameSpace.CreateRecipient("ownrAlias")
olFldrOwner.Resolve
Set olFolder = Nothing
If olFldrOwner.Resolved Then
Set olFolder = olNameSpace.GetSharedDefaultFolder(olFldrOwner, olFolderCalendar)
' If olFolder Is Nothing Then
' Debug.Print "Nothing"
' Else
' Debug.Print olFolder.Name '<-Error here if the if-block is run
' End If
'******************************
Set olFolder = olFolder.Folders("Transport Sched") '<-Object Not Found Error
'******************************
End If
'Code below updates appointments on the shared calendar
The full error
'The attempted operation failed. An object could not be found'
For testing, I added the commented out block. This made me think that the error might be in the previous line. When this block is un-commented then the code errors out on the line after Else (same error). So the olFolder object is not nothing, but it can't be found.
It's under "Shared Calendars" I get the error. It updates a calendar I created, that's under "My Calendars."
Is it a problem with finding the correct folder for the shared calendar?
The path to the folder shouldn't change, so I could hard-code it so it works for everyone, is that possible?
I came up with a solution to my problem but in a completely different way than I was trying with the code listed in the question. In case anyone else needs it, here is the solution:
Sub ListCalendars()
Dim olApp As Outlook.Application
Dim olPane As Outlook.NavigationPane
Dim olModule As Outlook.CalendarModule
Dim olGroup As Outlook.NavigationGroup
Dim olNavFolder As Outlook.NavigationFolder
Dim olFolder As Folder
Dim i As Integer, j As Integer
On Error Resume Next
' check if Outlook is running
Set olApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olPane = olApp.ActiveExplorer.NavigationPane
Set olModule = olPane.Modules.GetNavigationModule(olModuleCalendar)
Set olGroup = olModule.NavigationGroups.GetDefaultNavigationGroup(olMyFoldersGroup)
'Dummy Do loop allows exit from within nested For-Next loops
Do
For i = 1 To olModule.NavigationGroups.Count 'Cycle through all Nav Groups
Set olGroup = olModule.NavigationGroups.Item(i)
Debug.Print olGroup.Name
For j = 1 To olGroup.NavigationFolders.Count 'Cycle through all calendars in group
Set olNavFolder = olGroup.NavigationFolders.Item(j)
Debug.Print " - " & olNavFolder.DisplayName
'Un-comment If-block below if searching for a particular calendar:
'CalendarName is the name of the calendar,as listed in your navigation pane
' If olNavFolder.DisplayName = "CalendarName" Then
' Debug.Print "Found it!"
' Set olFolder = olNavFolder.Folder 'To get folder object from NavigationFolder
' Exit Do
' End If
Next
Next
Exit Do 'To prevent endless loop
Loop While True
'If-block below displays results if looking for matching calendar name
'If olFolder Is Nothing Then
' Debug.Print vbNewLine & "No match found"
'Else
' Debug.Print vbNewLine & "Matching calendar found: " & olFolder.Name
'End If
End Sub
This code was modified from this page here. Basically, accessing someone else's calendar folder object directly gave me issues, even if the calendar had been shared. By using the various navigation objects though, I was able to cycle through all the calendars listed in my navigation pane, including all the shared calendars.
As provided this routine merely lists the main folders and one level of subfolders. If the two if-blocks are uncommented then the routine will search for the calendar with a given name(just replace CalendarName) and will display whether or not a match was found.
The dummy Do loop was one way to break out of nested loops. There's multiple other ways to accomplish this listed in this SO question.
One other tricky thing is that NavigationFolder objects are NOT the same as Folder objects. This seemingly inconsequential line:
Set olFolder = olNavFolder.Folder
is actually very important if you want to make changes to the calendar folder, since these two object types have different properties and methods.
I have been searching how to fix this problem for sometime. It's hard to find specific answers without having to dive deep into VBA for outlook, which I would do if I have to.
I have a calendar update macro that should be adding appointments to our outlook calendar. I inherited the code, and just copied it and pasted it over, making some minor tweaks as far as cell references. The codes is below:
Sub CreateNewItems()
Dim dimnum As Integer
Dim num As Integer
Dim objOL 'As Outlook.Application
Dim objApt 'As Outlook.AppointmentItem
Dim objNamespace
Dim strFolderName
Dim objCalendar
Dim objInbox
Dim pctCompl As Single
Const olMeeting = 1
Const olFolderInbox = 6
Const olAppointmentItem = 1 '1 = Appointment
'do not display alerts
Application.DisplayAlerts = False
'do not update screen
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create new Undergrad info session events on Outlook Calendar
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Windows("WebScraper.xlsm").Activate
Sheets("Calendar Info Sess. Bridge").Activate
Set ws = ActiveSheet
ws.Range("B2").Select
ws.Range(Selection, Selection.End(xlDown)).Select
dimnum = Selection.count
ws.Range("B2").Select
num = 0
Do Until num = dimnum
Set objOL = CreateObject("Outlook.Application")
Set objNamespace = objOL.GetNamespace("MAPI")
'Finds your Inbox
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'Gets the parent of your Inbox which gives the Users email
strFolderName = objInbox.Parent
Set objCalendar = objNamespace.Folders(strFolderName).Folders("Calendar").Folders("Undergrad TNRB")
Set objApt = objCalendar.Items.Add(olAppointmentItem)
With objApt
.Subject = ActiveCell.Offset(0, 9).Value
.Location = ActiveCell.Offset(0, 4).Value
.start = ActiveCell.Offset(0, 1).Value & ActiveCell.Value
.End = ActiveCell.Offset(0, 3).Text & ActiveCell.Offset(0, 2).Value
.Save
End With
ActiveCell.Offset(1, 0).Select
num = num + 1
Loop
End Sub
From what I can tell, the problem is that in the With block, it should be .Start instead of .start. Unfortunately, every time I try to capitalize, VBA autocorrects back to .start. I do have some other subs that run before this code, but I removed any instance where I used the word "start", whether it was capitalized or not, commented, or executable code, so I'm not creating any variable unknowingly that this line would be trying to reference (as far as I can tell). I thought it might be that .Start is an VBA defined function, but I don't know enough to know if that's true, or what the needed convention would be to get this to save the appointment to outlook.
You can see that I am getting the number of rows in the sheet in the first couple of lines, and then I repeat the Do loop for every row of the sheet. Just as is intuitive in the With block, 9 columns to the right is a subject line for the appointment, 4 columns to the right is the location of the appointment, the active column is the date of the appointment starting, the next column over is the date the appointment ends (all events start and end on the same date), the column 2 to the right is the start time, and the column 3 to the right is the end time.
When I was running through the code, the time columns (columns 1 to the right and 3 to the right) were narrow, and visually these columns showed #s (just like excel does when the column isn't fully expanded). For some reason, the code was pulling the #s, rather than the actual value. It may have something to do with the .Text, but when I used .Value, it still wasn't working. So, if anyone else has this problem, try Columns.EntireColumn.Autofit on the columns that are too narrow that you're trying to pull values from.
I receive an automated email message (in Outlook) every time a room is reserved in a scheduling system but then have to go over and mirror that reservation in another system (which necessitates checking each reservation for specific information and searching through the inbox). I am trying to determine if there is a way to pull the information from the message section (I have found some code that pulls the date received, and subject line as well as read status, but cannot determine how to pull the message body information that I need)
The code that I am running is courtesy of Jie Jenn:
Sub ListOutlookEmailInfoinExcel()
Dim olNS As Outlook.NameSpace
Dim olTaskFolder As Outlook.MAPIFolder
Dim olTask As Outlook.TaskItem
Dim olItems As Outlook.Items
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant
Set olNS = GetNamespace("MAPI")
Set olTaskFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olItems = olTaskFolder.Items
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
On Error Resume Next
x = 2
arrHeaders = Array("Date Created", "Date Recieved", "Subject", "Unread?")
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeaders)).Value = ""
Do
With xlWB.Worksheets(1)
If Not (olItems(x).Subjects = "" And olItems(x).CreationTime = "") Then
.Range("A1").Resize(1, UBound(arrHeaders) + 1) = arrHeaders
.Cells(x, 1).Value = olItems(x).CreationTime
.Cells(x, 2).Value = olItems(x).ReceivedTime
.Cells(x, 3).Value = olItems(x).Subject
.Cells(x, 4).Value = olItems(x).UnRead
x = x + 1
End If
End With
Loop Until x >= olItems.Count + 1
Set olNS = Nothing
Set olTaskFolder = Nothing
Set olItems = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
With the above code, I get a readout of the Subject line, the date created/received and whether or not it has been read. I am trying to see if I can, in addition, get some of the unique string data within the message itself. The format of the emails that I receive is as follows:
Message-ID: sample info
User: test
Content1: test
Content2: test
Content3: test
Please submit a service request if you are receiving this message in error.
-Notice of NEW Room Request
Sponsored By: My_example#Test.com
Event Type: Meeting
Event Title: Test
Date of Reservation: 2015-12-02
Room: 150
From: 13:00
To: 14:00
The information will vary with each request, but I was wondering if anyone had any idea on how to capture the unique strings that will come through so that I can keep a log of the requests that is much faster than the current manual entry and double-checks?
As requested in follow up, the following code splits the message body into individual lines of information. A couple of notes: I copied your message exactly from your post, then searched for "Notice of NEW Room Request". Needless to say, this string should always start the block of information that you need. If it varies, then we have to account for the type of messages that may come through. Also, you may have to test how your message body breaks up individual lines. When I copied and pasted your message into Excel, each line break was 2 line feeds (Chr(10) in VBA). In some cases, it may be only one line feed. Or it can be a Carriage Return (Chr(13)), or even both.
Without further ado, see the code below and let us know of questions.
Sub SplitBody()
Dim sBody As String
Dim sBodyLines() As String
sBody = Range("A1").Value
sBodyLines() = Split(Mid(sBody, InStr(sBody, "Notice of NEW Room Request"), Len(sBody)), Chr(10) & Chr(10))
For i = LBound(sBodyLines) To UBound(sBodyLines)
MsgBox (sBodyLines(i))
Next i
End Sub
Below is an example connecting to an Outlook session, navigating to the default Inbox, then looping through items and adding unread emails to the spreadsheet. See if you can modify the code to your needs, and post back if specific help is needed.
Sub LinkToOutlook()
Dim olApp As Object
Dim olNS As Object
Dim olFolderInbox As Object
Dim rOutput As Range
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.getNamespace("MAPI")
Set olFolderInbox = olNS.GetDefaultFolder(6) 'Gets the default inbox folder
Set rOutput = Sheet1.Range("A1")
For Each itm In olFolderInbox.items
If itm.unread = True Then 'check if it has already been read
rOutput.Value = itm.body
Set rOutput = rOutput.Offset(1)
End If
Next itm
End Sub
Alternatively, you can write code in Outlook directly that looks for new mail arrival, and from there, you can test if it meets your criteria, and if it does, it can write to Excel. Here's a link to get you started. Post back for added help.
Using VBA to read new Outlook Email?