I am extremely new to VBA, I am trying to get files from a specific folder and sender and am using this code I found on YT, I added the sender section but I keep getting variable not defined:
Option Explicit
Sub getDataFromOutlookChoiceFolder()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.PickFolder
If Folder.Items.Count = 0 Then
MsgBox "No emails. Exiting procedure!"
Exit Sub
End If
i = 1
Dim rngName As Name
Sheet1.Cells.Clear
For Each rngName In ActiveWorkbook.Names
rngName.Delete
Next
Range("A1").Name = "email_Subject"
Range("A1") = "EmailSubject"
Range("B1").Name = "email_Date"
Range("B1") = "Email Date"
Range("C1").Name = "email_Sender"
Range("email_Sender")**.Value = InputBox("Enter Sender Addresss")**
Range("D1").Name = "email_Body"
Range("D1") = "Email Body"
Range("E1").Name = "email_Receipt_Date"
Range("email_Receipt_Date").Value = InputBox("Enter Receipt Date like 20-mar-2020")
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value **And OutlookMail.Sender = Range(“email_Sender”)** Then
Range("email_Subject").Offset(i, 0).Value = OutlookMail.Subject
Range("email_Subject").Offset(i, 0).Columns.AutoFit
Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_Date").Offset(i, 0).Columns.AutoFit
Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Sender").Offset(i, 0).Value = OutlookMail.SenderName
Range("email_Sender").Offset(i, 0).Columns.AutoFit
Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Body").Offset(i, 0).Value = OutlookMail.Body
Range("email_Body").Offset(i, 0).Columns.AutoFit
Range("email_Body").Offset(i, 0).VerticalAlignment = xlTop
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Highlighted is my changes. It works fine when just trying to select from a specific inbox
...And OutlookMail.Sender = Range(“email_Sender”)
You have "smart quotes" in there. VBA does not see those as actual quotes, but just another character, so it's sort of like writing
...And OutlookMail.Sender = Range(Xemail_SenderX)
You have not declared any variable named (eg) Xemail_SenderX, which is why you get the complaint about undeclared variable.
Related
I am trying to get the Alias ID of every received email from the sender's email address.
To get Alias you can right click on the received email, select open Outlook Properties.
I built a code that extracts email received in my inbox from a particular date specified in cell B.
I am trying to add the Alias ID in D4 onwards.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olExchgnUser As ExchangeUser
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.Folders("insert your own email address").Folders("inbox")
i = 1
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value Then
Range("email_Subject").Offset(i, 0).Value = OutlookMail.Subject
''Alias this is where i'm attempting to get Alias as part of the loop from every Item
Dim olNameSpace As Namespace
Dim olAddrList As AddressList
Set olAddrList = OutlookNamespace.AddressLists("Global Address List")
Set olExchgnUser = olAddrEntry.GetExchangeUser
With olExchgnUser
Range("Alias_name").Offset(i, 0) = .Alias
End With
''''ENd Alias
Range("email_Subject").Offset(i, 0).Columns.AutoFit
Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_Date").Offset(i, 0).Columns.AutoFit
Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Sender").Offset(i, 0).Value = OutlookMail.SenderName
Range("email_Sender").Offset(i, 0).Columns.AutoFit
Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Body").Offset(i, 0).Value = OutlookMail.Body
Range("email_Body").Offset(i, 0).Columns.AutoFit
Range("email_Body").Offset(i, 0).VerticalAlignment = xlTop
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
MsgBox "operation Complete"
End Sub
Replace the lines
Set olAddrList = OutlookNamespace.AddressLists("Global Address List")
Set olExchgnUser = olAddrEntry.GetExchangeUser
with
Set olExchgnUser = OutlookMail.Sender.GetExchangeUser
(null and error handling omitted).
You really should not be looping through all messages in a folder - use Items.Find/FindNext or Items.Restrict.
I have the code below which gives me the Sender line, Subject line and date information, however is there a way to also get the information from the To line (Name and Email Address).
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim I As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Mail").Folders("Test")
I = 1
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("eMail_subject").Offset(I, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(I, 0).Value = OutlookMail.ReceivedTime
Range("eMail_sender").Offset(I, 0).Value = OutlookMail.SenderName
Range("eMail_text").Offset(I, 0).Value = OutlookMail.Body
I = I + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Loop through all recipients in the MailItem.Recipients collection. If you only need To recipients, check the Recipient.Type property - it ca be olTo, olCC, olBCC
for each recip in OutlookMail .Recipients
if recip.Type = olTo Then
MsgBox recip.Name & ": " & recip.Address
End If
next
As a sidenote, the condition If OutlookMail.ReceivedTime >= Range("From_date").Value will never be satisfied - you cannot use equality comparison for the datetime values, you only only use a range: (value < const1) and (value > const2)
So, I've been wrestling with this task for WAY too long now. I am trying to make a button that creates an appointment and sends it to someone. So far, I've been successful in creating the appointment with the variables I want, but I can't figure out how to send it to the right person. Or send it at all for that matter. I'm very new to Outlook applications within VBA, so be gentle with me, but here is my code so far:
Sub appt()
Dim OutApp As Object
Dim OutMail As Object
Dim duedate As String
Dim currentrow As String
Dim currentsheet As String
Dim owner As String
currentsheet = ActiveSheet.Name
currentrow = Range("C10:C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
duedate = Range("C" & currentrow).Offset(0, 1)
owner = Range("C" & currentrow).Offset(0, 2)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
On Error Resume Next
With OutMail
.Recipients = Range("M3")
.Subject = "Next PDB Task for " & currentsheet
.Importance = True
.Start = "8:00 AM" & duedate
.End = "8:00 AM" & Format(Date + 5)
.ReminderMinutesBeforeStart = 10080
.Body = "Text and Stuff"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Emy
End Sub
So, this is definitely grabbing the information I want from the sheet it's run in, however it's not going anywhere. Do I need to use something other than .Recipients? Is it possible to forward this (with .Forward maybe?)? Any help would be greatly appreciated!!!
P.S. The email address I want to send the appointment to is in cell M3.
I didn't try the scripts, but it looks like they will do what you want.
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Dan Wilson")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = _
myNamespace.GetSharedDefaultFolder _
(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
excel vba create appointment in someone elses calendar
Sub MultiCalendars()
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objFolder As Folder
Dim calItem As Object
Dim mtgAttendee As Outlook.Recipient
Dim i As Integer
Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
DoEvents
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
Set objGroup = .GetDefaultNavigationGroup(olMyFoldersGroup)
' To use a different calendar group
' Set objGroup = .Item("Shared Calendars")
End With
For i = 1 To objGroup.NavigationFolders.Count
If (objGroup.NavigationFolders.Item(i).Folder.FullFolderPath = "\\Mailbox - Doe, John T\Calendar") Then
Set objNavFolder = objGroup.NavigationFolders.Item(i)
Set calItem = objNavFolder.Folder.Items.Add(olAppointmentItem)
calItem.MeetingStatus = olMeeting
calItem.Subject = "Test Meeting - Ignore"
calItem.Location = "TBD Location"
calItem.Start = #1/19/2015 1:30:00 PM#
calItem.Duration = 90
Set mtgAttendee = calItem.Recipients.Add("John Doe")
mtgAttendee.Type = olRequired
Set mtgAttendee = calItem.Recipients.Add("Jane Doe")
mtgAttendee.Type = olOptional
Set mtgAttendee = calItem.Recipients.Add("CR 101")
mtgAttendee.Type = olResource
calItem.Save
If (calItem.Recipients.ResolveAll) Then
calItem.Send
Else
calItem.Display
End If
End If
Next
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set calItem = Nothing
Set mtgAttendee = Nothing
End Sub
https://answers.microsoft.com/en-us/office/forum/office_2010-customize/excel-vba-create-an-appointment-in-someone-elses/4c2ec8d1-82f2-4b02-abb7-8c2de2fd7656?auth=1
I am trying to set Outlook appointments from a userform in Excel. The code works if I am referencing cells. How do I reference boxes in a userform? I also need to add to the code recipients for the meeting which I would reference from a different list worksheet.
Here is the code that references the cells in Excel which works by clicking a button in the worksheet:
Sub AddAppointments()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
' Start at row 2
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
' Create the AppointmentItem
Set myApt = myOutlook.CreateItem(1)
' Set the appointment properties
myApt.Subject = Cells(r, 1).Value
myApt.Location = Cells(r, 2).Value
myApt.Start = Cells(r, 3).Value
myApt.Duration = Cells(r, 4).Value
' If Busy Status is not specified, default to 2 (Busy)
If Trim(Cells(r, 5).Value) = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Cells(r, 5).Value
End If
If Cells(r, 6).Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
Else
myApt.ReminderSet = False
End If
myApt.Body = Cells(r, 7).Value
myApt.Display
r = r + 1
Loop
End Sub
This is my attempt at changing the code to reference boxes in a userform:
Private Sub Cmdappointment_Click()
Dim outlookapp As Object
'the mail item is the contents inside a mail
Dim mitem As AppointmentItem
'created outlook app
Set outlookapp = CreateObject("outlook.Application")
'it will open a new application
Set outlookapp = New Outlook.Application
'Set mail item
Set mitem = outlookapp.CreateItem(olMailItem)
Do Until userform2.TextBox4.Value = ""
' Create the AppointmentItem
Set myApt = myOutlook.CreateItem(1)
' Set the appointment properties
On Error Resume Next
mitem
myApt.Subject = Me.texbox4.Value
myApt.Location = Me.texbox3.Value
myApt.Start = Me.ComboBox1.Value
myApt.Duration = Me.ComboBox2.Value
' If Busy Status is not specified, default to 2 (Busy)
If Me.ComboBox3.Value = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Me.ComboBox3.Value
End If
If Me.TextBox1.Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Me.TextBox1.Value
Else
myApt.ReminderSet = False
End If
myApt.Body = Me.TextBox2.Value
myApt.Display
End With
Loop
End Sub
Sorry couldn't fit the code in the comments so here are a couple of issues...
You are creating outlookapp and using myOutlook Object.
And also you are creating two mail items mitem and myApt each respectively from outlookapp and myOutlook. Eventually using only myApt. I do not know the origins of myOutlook. But I would rewrite the code to use just one set. One set of OutLook and MailItem objects just like in your worksheet application
Set outlookapp = CreateObject("outlook.Application")
'it will open a new application
Set outlookapp = New Outlook.Application
'Set mail item
Set mitem = outlookapp.CreateItem(olMailItem)
Do Until userform2.TextBox4.Value = ""
' Create the AppointmentItem
Set myApt = myOutlook.CreateItem(1)
To add recipients do the below
myApt.Recipients.Add('j doe')
To make it a bit more safe I would add the below line as well
Dim myApt As AppointmentItem
Sub cmdappointment_Click()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
Do Until userform2.TextBox4.Value = ""
' Create the AppointmentItem
Set myApt = myOutlook.CreateItem(1)
' Set the appointment properties
myApt.Subject = userform2.TextBox4.Value
myApt.Location = userform2.TextBox3.Value
myApt.Start = userform2.ComboBox1.Value
myApt.Duration = userform2.ComboBox2.Value
' If Busy Status is not specified, default to 2 (Busy)
If userform2.ComboBox3.Value = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = userform2.ComboBox3.Value
End If
If userform2.TextBox1.Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = userform2.TextBox1.Value
Else
myApt.ReminderSet = False
End If
myApt.Body = userform2.TextBox2.Value
myApt.Display
Exit Do
Loop
End Sub
I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.
The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).
When I clicked debug, it points to this line of code:
For Each itm In subFld.Items
Here is the screenshot:
Here is the full code:
Public monthValue As Integer
Public yearValue As String
'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long
'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.
'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True 'Show my workbook.
'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
'No subfolder.
For Each itm In mainFld.Items
If itm.Class <> olMail Then '2
'do nothing
Else
Set msg = itm
'Validate the month and year for the email.
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount 'Track the number of email.
Else
'Do nothing
End If '3
End If '2
Next itm
Else
'With subfolder
For Each itm In mainFld.Items
If itm.Class <> olMail Then '4
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '5
End If '4
Next itm
For Each subFld In mainFld.Folders
For Each itm In subFld.Items
If itm.Class <> olMail Then '6
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '7
End If '6
Next itm
Next subFld
End If '1
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
'Inform the user that there are no email.
If emailCount = 0 Then
MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
End Sub
Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?
Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.
EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.
set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
set itm = fldItems.Item(i)
'do stuff
set itm = Nothing
next
As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.