I am working on creating a macro in Outlook VBA that aims to copy contacts from my default contact-folder to another contact-folder, conditioned by the values of a user-defined field. When refrencing the value of a built in field, the code works as desired. However, the problem arrises when trying to reference the values of a user-defined field. My code seems to be unable to reach the field.
Here, when referencing to the title of the contact ("title" being a built-in field), VBA finds it immediately and there is no problem.
Sub copyitem() ' Copy and move all contacts from default folder "Contacts" to "Contacts.1.01
Dim olookitem As Object
Dim olookname As NameSpace
Dim olookfldr As folder
Dim destfolder As folder
Dim olookcontactitem As ContactItem
Dim mycopieditem As ContactItem
Set olookname = Application.GetNamespace("MAPI")
Set olookfldr = olookname.GetDefaultFolder(olFolderContacts)
Set destfolder = olookfldr.Folders("Contacts.1.01")
For Each olookitem In olookfldr.items
If olookitem.Class = olContact And olookitem.Title = "Mr." Then
Set olookcontactitem = olookitem
Set mycopieditem = olookitem.Copy
mycopieditem.Move destfolder
End If
Next
End Sub
However, when trying to reference which team in my office the contact belongs to (Column named "Team"), which is defined in a user-defined field, my macro fails to recognize it. Code following below.
Sub copyitem() ' Copy and move all contacts from default folder "Contacts" to "Contacts.1.01
Dim olookitem As Object
Dim olookname As NameSpace
Dim olookfldr As folder
Dim destfolder As folder
Dim olookcontactitem As ContactItem
Dim mycopieditem As ContactItem
Dim Myproperty As Object
Set olookname = Application.GetNamespace("MAPI")
Set olookfldr = olookname.GetDefaultFolder(olFolderContacts)
Set destfolder = olookfldr.Folders("Contacts.1.01")
Set Myproperty = olookfldr.UserDefinedProperties.Find("Team")
Set MyP = olookfldr.UserDefinedProperties
' MsgBox (MyP.item(1).Name)
For Each olookitem In olookfldr.items
If olookitem.Class = olContact And MyP.item(9).Name = "Accounting" Then
Set olookcontactitem = olookitem
Set mycopieditem = olookitem.Copy
mycopieditem.Move destfolder
End If
Next
End Sub
User-defined (and all other) properties can be retrieved using ContactItem.PropertyAccessor.GetProperty. The method takes the DASL property name as the parameter; to see the properties and their DASL names, take a look at an item with that property set with OutlookSpy (I am its author) - click IMessage button, select the property, see its DASL name.
You can also retrieve a user property using ContactItem.UserProperties.Item("PropertyName"), but the custom property must be added as a user property, while ContactItem.PropertyAccessor.GetProperty can retrieve any available property.
You need to get the property value of the user-defined field from the contact item, not folder:
Dim userProps as Outlook.UserProperties
Dim userProp as Outlook.UserProperty
For Each olookitem In olookfldr.items
If olookitem.Class = olContact The
Set olookcontactitem = olookitem
Set userProps = olookcontactitem.UserProperties
Set userProp = userProps.Find("Team")
Dim value as String = userProp.Value
If value = "Accounting" Then
Set mycopieditem = olookitem.Copy
mycopieditem.Move destfolder
End If
End If
Next
Related
I would like to run a macro to do follow steps:
- save PDF only attachment to hard drive
- save it with a revise name filename & domain name.
Here is the code I search from open source and mix it together. any help is appreciated. thanks
Public Sub Download_Attachments()
Dim ns As NameSpace
Dim olFolder_Inbox As Folder
Dim olMail As MailItem
Dim olAttachment As Attachment
Dim strFolderPath As String
Dim strFileName As String
Dim strSenderAddress As String
Dim strSenderDomain As String
Dim fso As Object
strFolderPath = "C:\"
Set ns = GetNamespace("MAPI")
Set fso = CreateObject("Scripting.FileSystemObject")
Set olFolder_Inbox = Application.ActiveExplorer.CurrentFolder
Set olMail = Application.ActiveWindow.CurrentItem
'Get sender domain
strSenderAddress = olMail.SenderEmailAddress
strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "#"))
For Each olMail In olFolder_Inbox.Items
If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
For Each olAttachment In olMail.Attachments
Select Case UCase(fso.GetExtensionName(olAttachment.FileName))
Case "PDF", "pdf"
olAttachment.SaveAsFile strFolderPath & strFileName
Case Else
'skip
End Select
Next olAttachment
End If
Next olMail
Set olFolder_Inbox = Nothing
Set fso = Nothing
Set ns = Nothing
End Sub
The following line of code retrieves the active folder in the Explorer window, not the Inbox one. Outlook can be started with any active folder, you can specify the folder name to the Outlook.exe file. To get the default folders (Inbox) you need to use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Calendar folder for the user who is currently logged on. For example, the following sample code uses the CurrentFolder property to change the displayed folder to the user's default Inbox folder.
Sub ChangeCurrentFolder()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
Set Application.ActiveExplorer.CurrentFolder = myNamespace.GetDefaultFolder(olFolderInbox)
End Sub
Then it is not really recommended to iterate over all items in the folder.
For Each olMail In olFolder_Inbox.Items
Instead, you need to use the Find/FindNext or Restrict methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
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
Finally, the part you are interested in is the SaveAsFile method of the Attachment class which saves the attachment to the specified path:
olAttachment.SaveAsFile strFolderPath & domainName & strFileName
Make sure a qualified file path is passed as a parameter. I'd recommend running the code under the debugger and see what values are passed.
I am attempting to add convenience when adding notes to emails in Outlook.
My plan is to take my current procedure, which adds the notes to the selected email (as an attachment), and have it call a procedure which will set a UserProperty on the MailItem object so that I can easily see which emails have notes attached by adding a custom column to my email list view.
From scouring the internet I have pieced together the following.
Option Explicit
Public Sub MarkHasNote()
Dim Selection As Outlook.Selection
Dim UserDefinedFieldName As String
Dim objProperty As Outlook.UserProperty
Dim objItem As MailItem
UserDefinedFieldName = "Note"
Set objItem = GetCurrentItem()
Set objProperty = objItem.UserProperties.Add(UserDefinedFieldName, Outlook.OlUserPropertyType.olYesNo, olFormatYesNoIcon)
objProperty.Value = True
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
I have set a breakpoint and checked the UserProperties of the MailItem. I see that the details are there and the value is set to "True". However, the email does not show the Yes/No icon in the "Note" column of the email pane of Outlook.
How do I get Outlook to show my user defined property value in the email pane when I add the column to the view?
A save is required for a selection. An Inspector item prompts for a save.
Private Sub MarkHasNote_DisplayTest()
' Add the UserProperty column with Field Chooser
' You can view the value toggling when you run through the code
Dim Selection As Selection
Dim UserDefinedFieldName As String
Dim objProperty As UserProperty
Dim objItem As mailItem
UserDefinedFieldName = "NoteTest"
Set objItem = GetCurrentItem()
Set objProperty = objItem.UserProperties.Add(UserDefinedFieldName, Outlook.OlUserPropertyType.olYesNo, olFormatYesNoIcon)
objProperty.Value = Not objProperty.Value
' Required for an explorer selection
objItem.Save
' For an inspector item there would be a prompt to save
' if not already done in the code
End Sub
I'm trying to create a recursive function which adds each folder (and subfolders) to a collection of custom objects. My code is working for around 75% of the folders / subfolders but seemingly random ones are being missed from the collection.
Any ideas?
FolderObj is a custom class, the collection I'm adding to is called ToPathList
Option Explicit
Sub RecurseFolderList(Foldername As String)
On Error Resume Next
Dim FSO, NextFolder
Dim OriginalRange As Range
Dim tempFolderObj As FolderObj
Dim i As Integer
i = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
Exit Sub
End If
If FSO.FolderExists(Foldername) Then
Set NextFolder = FSO.GetFolder(Foldername)
Set FolderArray = NextFolder.subfolders
For Each NextFolder In FolderArray
Set tempFolderObj = New FolderObj
'assign variables to temporary object
With tempFolderObj
.ID = i
.Filename = NextFolder.Name
.path = NextFolder.path
.first3ints = first3Non0Ints(NextFolder.Name)
End With
'add temporary object to colelction
Call ToPathList.Add(tempFolderObj, CStr(i))
i = i + 1
RecurseFolderList (NextFolder)
Next
' Set NextFolder = Nothing
' Set FolderArray = Nothing
End If
Set FSO = Nothing
End Sub
My key (i) was declared inside the function and therefore was being reset to '1' every time the function was recursed.
This resulted in non-unique keys and therefore some items were not being added to the collection.
Thanks to everyone for their help.
Is there a way to extract the details in this dialog box via VBA?
Details Dialog Box http://i.msdn.microsoft.com/dynimg/IC84336.gif
I need, especially the content in the E-Mail address tab.
You can pretty much get the fields easily, the E-mail Addresses is the harder part. References: Microsoft Exchange Property Tags
This code exports some details but most importantly the Email addresses to a text file.
Sub ListGAL()
On Error Resume Next
Const LogFile = "C:\Test\OLK_GAL.log"
Const sSCHEMA = "http://schemas.microsoft.com/mapi/proptag/0x"
Const PR_EMS_AB_PROXY_ADDRESSES = &H800F101E
Dim oNameSpace As NameSpace, oGAL As AddressList, oEntry As AddressEntry
Dim oFSO As Variant, oLF As Variant, oExUser As ExchangeUser, i As Long
' Oulook objects
Set oNameSpace = Outlook.Application.GetNamespace("MAPI")
' Global Address List object
Set oGAL = oNameSpace.AddressLists("Global Address List")
'----------
' Log file objects
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oLF = oFSO.CreateTextFile(LogFile)
'----------
For Each oEntry In oGAL.AddressEntries
i = i + 1
Debug.Print i & vbTab & oEntry.Name
If oEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
oLF.WriteLine "Entry " & i & " (olExchangeUserAddressEntry)"
oLF.WriteLine "Name: " & oEntry.Name
oLF.WriteLine "Address: " & oEntry.Address
Set oExUser = oEntry.GetExchangeUser
' SMTP ADDRESSES
oLF.WriteLine "SMTP Addresses:"
oLF.WriteLine vbTab & Join(oExUser.PropertyAccessor.GetProperty(sSCHEMA & Hex(PR_EMS_AB_PROXY_ADDRESSES)), vbCrLf & vbTab)
Set oExUser = Nothing
oLF.WriteLine String(50, Chr(151)) ' Separator
End If
Next
'----------
' Close Log File, clean up
oLF.Close
Set oGAL = Nothing
Set oNameSpace = Nothing
Set oLF = Nothing
Set oFSO = Nothing
End Sub
i have go a function of reading the address-book:
Function Get_mail(Absender As String)
Dim OutApp As Outlook.Application
Dim OutTI As Outlook.TaskItem
Dim OutRec As Outlook.Recipient
Set OutApp = New Outlook.Application
Set OutTI = OutApp.CreateItem(3)
OutTI.Assign
Set OutRec = OutTI.Recipients.Add(Absender)
OutRec.Resolve
If OutRec.Resolved Then
On Error GoTo exit_function
Get_mail = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
exit_function: Exit Function
Set OutApp = Nothing
Set OutTI = Nothing
End Function
as far as I know you can only read out the Primary Mail-address from the mail-addresses-tab; to see what else there ist delete the part ".PrimarySmtpAddress", mahe the dot and you should get the list of other properties.
I am quite sure you need the reference on Microsoft Outlook 14.0 Object Library.
The Input "Absender" can be any string . if this string can be resolved as address book-entry in an outlook-mail, you will also have a positive result from the code above.
To call the function, if for example you have a string "mail_adress_from_adressbook" you would put:
mail_adress_from_adressbook = get_mail("Joe Smith")
I hope this helps,
Max
Sure, you can access any GAL object property shown by Outlook (and then some) even if the properties are not explicitly exposed by the AddressEntry or ExchangeUser objects using AddressEntry.PropertyAccessor.GetProperty as long as you know the MAPI property's DASL name
The DASL property names can be retrieved using OutlookSpy (I am its author): either click IAddrBook button to drill down to a particular address entry or, if you have a message addressed to one of the GAL recipients, click IMessage button, go to the GetRecipientTable tab, double click on the recipient to open it as IMailUser:
In your particular case, you need PR_EMS_AB_PROXY_ADDRESSES (DASL name "http://schemas.microsoft.com/mapi/proptag/0x800F101F") - it is a multivalued string property, which means AddressEntry.PropertyAccessor.GetProperty will return an array of strings. Each value is prefixed with the address type (e.g. "EX:" or "smtp:"), the default SMTP address will be prefixed with "SMTP:" (note the upper case):
Set User = Application.session.CurrentUser.AddressEntry
AddressList = User.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x800F101F")
If IsArray(AddressList) Then
For i = LBound(AddressList) To UBound(AddressList)
MsgBox AddressList(i)
Next
End If
I am trying to extract email addresses of all emails in my Outlook inbox. I found this code on the Internet.
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object
''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
dic.Add strEmail, ""
End If
I am using outlook 2007. When I run this code from the Outlook Visual Basic Editor with F5 I get an error on the following line.
Dim dic As New Dictionary
"user defined type not defined"
I have provided updated code below
to dump the Inbox email addresses to a CSV file "c:\emails.csv" (the current code provides no "outlook" for the collected addresses
the code above works on a selected folder rather than Inbox as per your request
[Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]
Part A: Your existing code (early binding)
In terms of the error you received:
The code sample aboves uses early binding, this comment "Requires reference to Microsoft Scripting Runtime" indciates that you need to set the reference
Goto the Tools menu
Select 'References'
check "Microdoft Scripting Runtime"
Part B: My new code (late binding - setting the reference is unnecessary)
Working Code
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.writeline strEmail
objDic.Add strEmail, ""
End If
End If
Next
objTF.Close
End Sub
export the file to C:\Users\Tony\Documents\sent file.CSV
Then use ruby
email_array = []
r = Regexp.new(/\b[a-zA-Z0-9._%+-]+#[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/)
CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
email_array << row.to_s.scan(r)
end
puts email_array.flatten.uniq.inspect
Here's an updated version for those using Exchange. It converts Exchange format addresses to normal email addresses (with the # symbol).
' requires reference to Microsoft Scripting Runtime
Option Explicit
Sub Write_Out_Email_Addresses()
' dictionary for storing email addresses
Dim email_list As New Scripting.Dictionary
' file for output
Dim fso As New Scripting.FileSystemObject
Dim out_file As Scripting.TextStream
Set out_file = fso.CreateTextFile("C:\emails.csv", True)
' open the inbox
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim inbox As MAPIFolder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' loop through all items (some of which are not emails)
Dim outlook_item As Object
For Each outlook_item In inbox.Items
' only look at emails
If outlook_item.Class = olMail Then
' extract the email address
Dim email_address As String
email_address = GetSmtpAddress(outlook_item, ns)
' add new email addresses to the dictionary and write out
If Not email_list.Exists(email_address) Then
out_file.WriteLine email_address
email_list.Add email_address, ""
End If
End If
Next
out_file.Close
End Sub
' get email address form a Mailoutlook_item
' this entails converting exchange format addresses
' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
' to proper email addresses
Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
Dim success As Boolean
success = False
' errors can happen if a user has subsequently been removed from Exchange
On Error GoTo err_handler
Dim email_address As String
email_address = outlook_item.SenderEmailAddress
' if it's an Exchange format address
If UCase(outlook_item.SenderEmailType) = "EX" Then
' create a recipient
Dim recip As Outlook.Recipient
Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
' extract the email address
Dim user As Outlook.ExchangeUser
Set user = recip.AddressEntry.GetExchangeUser()
email_address = user.PrimarySmtpAddress
email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
success = True
End If
err_handler:
GetSmtpAddress = email_address
End Function
Kudos to http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email and Brettdj
In outlook, export a folder to a csv file, then open in Excel. A simple MID function should be able to extract the email address if it's not been placed in a "from" column already.