I would like to import mail data from Outlook.
I have no problem to import classic fields such as: From, Subject ... etc. I cannot find how to import my "User-defined field".
The User-defined field is named "DemandQTY" and contains only numbers.
I get my data from a shared mailbox.
Sub GetFromOutlook()
Dim OutApp As Outlook.Application
Dim OutNS As Namespace
Dim Folder As MAPIFolder
Dim OutMail As Variant
Dim i As Integer
Dim objOwner As Outlook.Recipient
Dim FileName As String
Dim MI As Outlook.MailItem
Dim Item As Object
Dim Atmt As Attachment
Set OutNS = GetNamespace("MAPI")
Set OutApp = New Outlook.Application
Set objOwner = OutNS.CreateRecipient("emailadress")
objOwner.Resolve
If objOwner.Resolved Then
Set Folder = OutNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
i=2
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
' (etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
i = i + 1
Next OutMail
MsgBox "Importation Terminée"
Sheets(2).Select
Sheets(2).Cells(1, 1).Select
Set OutApp = Nothing
Set OutNS = Nothing
Set Folder = Nothing
End If
End Sub
I tried different methods found on internet, but nothing worked.
We can do this by first testing if the property exists. If it doesn't and you try to work with it, it will throw an error. Afterwards we can access the value if the property is found.
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
(etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
If Not(OutMail.UserProperties.Find("DemandQTY", True) Is Nothing) Then
Sheets(2).Cells(i, 33) = OutMail.UserProperties("DemandQTY").Value
End If
i = i + 1
Next OutMail
Related
found a code below and im trying to get the email address in my outlook inbox into excel but errors in line set objfolder
Sub getemail()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim objItem As Object
Dim counter As Integer
counter = 2
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail And objItem.ReceivedTime >= DateAdd("yyyy", -1, Now) Then
strEmail = objItem.SenderEmailAddress
Cells(counter, 1).Value = strEmail
counter = counter + 1
End If
Next
End Sub
I am not sure if it got to do with late binding/early binding issue. But you can try to change the "olFolderInbox" to 6.
If you want to use the early binding, make sure your Microsoft Outlook XX.X object library is enabled in your reference.
I typically will use late binding, it will be a lot simpler and you don't have to deal with the reference library version issue. When sharing the sub routine with another colleague or friend with different Excel version
Sub Get_Name()
Dim OLApp As Object
Dim oNameSpace As Object
Dim oFolder As Object
Dim oMail As Object
Set OLApp = CreateObject("Outlook.Application")
Set oNameSpace = OLApp.GetNameSpace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(6) 'olFolderInbox: 6, Inbox folder
For Each oMail In oFolder.items
On Error Resume Next
Debug.Print oMail.SenderEmailAddress
'Do your stuff here....
On Error GoTo 0
Next oMail
End Sub
Firstly, never loop through all items in a folder - folders can contain thousands of messages, use Items.Find/FindNext or Items.Restrict.
Secondly, Inbox folder can contain items other than MailItem, such as ReportItem or MeetingItem, which do not expose the SenderEmailAddress property. Check the Class property (exposed by all OOM object) that you indeed have a MailItem object.
Finally, Application intrinsic variable points to the Excel.Application object in Excel VBA. You need to explicitly create an instance of the Outlook.Application object if unless you are running your code in Outlook VBA.
set OlApp = CreateObject("Outlook.Application")
Set objFolder = OlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
set restrictedItems = objFolder.Items.Restrict("[ReceivedTime] >= '02-07-2023' ")
For Each objItem In restrictedItems
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
Cells(counter, 1).Value = strEmail
counter = counter + 1
End If
Next
by #Dmitry
make sure to add outlook as project preference
Sub getemail()
Dim OLApp As Object
Dim objFolder As Object
Dim objItem As Object
Dim restrictedItems As Object
Dim olFolderInbox As Object
Dim strEmail As String
Dim counter As Integer
counter = 2
Set OLApp = CreateObject("Outlook.Application")
Set objFolder = OLApp.GetNamespace("MAPI").GetDefaultFolder(6)
Set restrictedItems = objFolder.Items.Restrict("[ReceivedTime] >= '02-07-2023' ")
For Each objItem In restrictedItems
If objItem.Class = 43 Then
strEmail = objItem.SenderEmailAddress
Cells(counter, 1).Value = strEmail
counter = counter + 1
End If
MsgBox "Email address copied"
Next
End Sub
I have a database, just with names and e-mail addresses and I need to create individual e-mails with a specific fixed text, that is in a specific range of my excel and save it in a specific folder of my hard drive.
However, I'm having problems with the body text.
Here it is the code:
Sub test()
Dim Sendrng As Range
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Dim i As Integer
For i = 2 To ActiveSheet.Cells(5, 2).Value + 1
Set Sendrng = ActiveSheet.Range("B12:K29")
Set outlookApp = New Outlook.Application
Set outlookMail = outlookApp.CreateItem(olMailItem)
With outlookMail
.To = ActiveSheet.Cells(7, 2).Value
.Subject = ActiveSheet.Cells(8, 2).Value
'.HTMLBody = Sendrng
.Save
End With
i = i + 1
ActiveSheet.Cells(4, 2) = i
Set outlookMail = Nothing
Set outlookApp = Nothing
Next i
'I want to start every time in position 2
ActiveSheet.Cells(4, 2) = 2
End Sub
Can you explain to me where is missing? I'm getting the following error: Run-time Error 13: Type mismatch
Thanks,
Henrique
You need to use the Text property of the Range class instead of Value:
Sub test()
Dim Sendrng As Range
Dim outlookApp As Outlook.Application
Dim outlookMail As Outlook.MailItem
Dim i As Integer
For i = 2 To ActiveSheet.Cells(5, 2).Value + 1
Set Sendrng = ActiveSheet.Range("B12:K29")
Set outlookApp = New Outlook.Application
Set outlookMail = outlookApp.CreateItem(olMailItem)
With outlookMail
.To = ActiveSheet.Cells(7, 2).Text
.Subject = ActiveSheet.Cells(8, 2).Text
.Save
End With
i = i + 1
ActiveSheet.Cells(4, 2) = i
Set outlookMail = Nothing
Set outlookApp = Nothing
Next i
'I want to start every time in position 2
ActiveSheet.Cells(4, 2) = 2
End Sub
I am trying to pull the sender's email address from every email in an inbox folder
I am not having any problems until I reach my For command for each email in the folder.
If I use the code as it is now I run into an error because olSender is not Dim As Variant, but if I change it to Dim As Variant I cannot Dim it as an Outlook.MailItem to retrieve the senderEmailAddress.
I'm assuming a nested For loop is the solution. Outlook 2013 is the version.
Sub ExportToExcel()
'EXCEL
'Opening Excel workbook
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
oXLApp.Visible = True
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\******\Documents\******.xlsm")
Set oXLws = oXLwb.Sheets("Sheet1")
oXLws.Range("A" & 1).Select
'OUTLOOK
'Opening Outlook folder
Dim olNS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set olNS = Application.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("*********#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set BouncedEmailsFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderInbox).Folders("Bounced Emails")
End If
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Dim olSender As Outlook.MailItem
Set olItms = BouncedEmailsFolder.Items
olItms.Sort ("Subject")
i = 1
For Each olSender In olItms
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
Next olSender
Set BouncedEmailsFolder = Nothing
Set olNS = Nothing
End Sub
Your code works for me when set to my default inbox.
olNS.GetDefaultFolder(olFolderInbox)
I wonder if you're not coming across non-mail items in your bounced emails? You may want to try the code below, which will retrieve mail items only (instead of also trying to extract the sender for meeting requests, task assignments, etc):
For Each olSender In olItms
If TypeOf olSender Is MailItem Then
oXLws.Select
oXLws.Cells(i, 1).Select
oXLws.Cells(i, 1).Value = olSender.SenderEmailAddress
i = i + 1
End If
Next olSender
Each employee gets an updated contact list. I'm creating a macro in Excel that will delete all outlook contacts, then import all the contacts on that sheet into their main outlook contacts. Not all users are on the same outlook version, so I can't use Early Binding methods since the Outlook OBJ Library cannot be referenced between versions.
I managed to get my delete loop into late binding easily, but I'm having trouble getting the import code to work in late binding. Here is the working early binding method I currently have for the import:
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olConItems As Outlook.Items
Dim olItem As Object
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
'Location in the imported contact list.
Dim lnContactCount As Long
Dim strDummy As String
'Turn off screen updating.
Application.ScreenUpdating = False
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'Format the target worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private Person"
.Cells(1, 2).Value = "Street Address"
.Cells(1, 3).Value = "Postal Code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact Person"
.Cells(1, 6).Value = "E-mail"
With .Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
wsSheet.Activate
'Initalize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olConItems = olFolder.Items
'Row number to place the new information on; starts at 2 to avoid overwriting the header
lnContactCount = 2
'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
'otherwise, write out the personal info.
For Each olItem In olConItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) > 0 Then
Cells(lnContactCount, 1).Value = .CompanyName
Cells(lnContactCount, 2).Value = .BusinessAddressStreet
Cells(lnContactCount, 3).Value = .BusinessAddressPostalCode
Cells(lnContactCount, 4).Value = .BusinessAddressCity
Cells(lnContactCount, 5).Value = .FullName
Cells(lnContactCount, 6).Value = .Email1Address
Else
Cells(lnContactCount, 1) = .FullName
Cells(lnContactCount, 2) = .HomeAddressStreet
Cells(lnContactCount, 3) = .HomeAddressPostalCode
Cells(lnContactCount, 4) = .HomeAddressCity
Cells(lnContactCount, 5) = .FullName
Cells(lnContactCount, 6) = .Email1Address
End If
wsSheet.Hyperlinks.Add Anchor:=Cells(lnContactCount, 6), _
Address:="mailto:" & Cells(lnContactCount, 6).Value, _
TextToDisplay:=Cells(lnContactCount, 6).Value
End With
lnContactCount = lnContactCount + 1
End If
Next olItem
'Null out the variables.
Set olItem = Nothing
Set olConItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
With wsSheet
.Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox "The list has successfully been created!", vbInformation
End Sub
To use Late binding, you should declare all your Outlook-specific objects as Object:
Dim olApp As Object, olNamespace As Object, olFolder As Object, olConItems As Object
Then:
Set olApp = CreateObject("Outlook.Application")
This will make each computer create the olApp object from the Outlook library that is installed on it. It avoids you to set an explicit reference to Outlook14 in the workbook that you will distribute (remove that reference from the project before distributing the Excel file).
Hope this helps :)
All of your Outlook object declarations would first have to become non-Oulook related object declarations.
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olConItems As Object
Dim olItem As Object
You will need a CreateObject function on the Outlook.Application object.
Set olApp = CreateObject("Outlook.Application")
Everything else should fall into place.
I am to write a VBA code that would retrive emails from Outlook based on certain conditions. The problem I have is that I have to denote a certain folder in my code (in the example below the folder denoted is "PRE Costumer". I would like to retrive all emails from my 'inbox' or in better case from all outlook folders. The problem is that my inbox consists of many subfolders (because of rules0. My problem is that I may not know all the subfolders names (as many useres are going to use the macro and even someone can have the e mails in Personal Folders).
Could you please advise is there a way to overcome this problem?
Please let me know if this question is vague (as I am newcomer)
Please find the line that I have probelm with marked with a comment.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Below is the line I have problem with
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
i = 1
x = Date
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Just loop through all the folders in Inbox.
Something like this would work.
Edit1: This will avoid blank rows.
Sub test()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = Activesheet '~~> or you can be more explicit using the next line
'Set ws = Thisworkbook.Sheets("YourTargetSheet")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
'Debug.Print eFolder.Name
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlup).Row
.Range("A" & lrow).Offset(1,0).value = olMail.Subject
.Range("A" & lrow).Offset(1,1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1,2).Value = olMail.SenderName
End With
End If
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Above takes care of all subfolders in Inbox.
Is this what you're trying?
To fix your error (olFolderInbox is a Outlook only constant, so you need to define it in vba that is not Outlook):
Const olFolderInbox = 6
'...
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Also to prevent missing Reference when run from another computer, I would:
Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim olMail As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
'...
You might also want to disable ScreenUpdating, then enable it in Excel if you expect a long list.
UPDATE (Solution for all folders from a Root Folder)
I used something slightly different for comparing the dates.
Option Explicit
Private lRow As Long, x As Date, oWS As Worksheet
Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Set oWS = ActiveSheet
x = Date
lRow = 1
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
GetFromFolder oRootFldr
Application.ScreenUpdating = True
Application.Calculation = lCalcMode
Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If InStr(1, .Subject, "transactions", vbTextCompare) > 0 And DateDiff("d", .ReceivedTime, x) = 0 Then
oWS.Cells(lRow, 1).Value = .Subject
oWS.Cells(lRow, 2).Value = .ReceivedTime
oWS.Cells(lRow, 3).Value = .SenderName
lRow = lRow + 1
End If
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub