Outlook

Auto-Create Contact Items from Email Recipients (To, From, Cc, Bcc)

Ease of Use

Intermediate

Version tested with

2000,2002,2003,2007 

Submitted by:

matthewspatrick

Description:

UserForm-assisted code that will scan recipients of the current email message, and turn them into Contacts (with optional Company and/or Category assignments) 

Discussion:

In Outlook, you can right-click on an email recipient, and add that person as a Contact item. This works great--unless you have an email with a dozen new people in the recipients, each of whom (or ten of whom) you want to create Contact items for. This package allows a user to run a macro, AutoCreateContacts, to cycle through the recipients, and selectively add them as new Contacts. Also, as long as all of your new Contacts get the same assignments, you can automatically assign your new Contacts to a Company and/or one or more Categories. (You can also create new Categories, if needed.) This code was jointly developed by Patrick G. Matthews and David ??? (aka BlueDevilFan) References: http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21413779.html http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21417753.html http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21418326.html Please be advised that, if you use Outlook 2000 SP2 or later, this code will trigger Outlook's security warnings. You can use third-party tools like Express Click-Yes or MAPILab's Advanced Outlook Security to handle these warnings. Future development might include support using Redemption.dll to preempt the security warnings. 

Code:

instructions for use

			

'Code for Main Module (modAutoCreateContacts) ' This module and associated UserForms (frm1AutoCreateContacts and frm1AutoCreateContacts) will ' do the following if the current active item is a Mail item: ' 1. Offer to create Contacts out of To, From, CC, and/or BCC recipients ' 2. Produce such a list for the user to review and select/deselect ' 3. Create new Contact items for selected members of the list, with optional Company and ' Categories designations ' This code has been tested with Outlook 2000, Outlook XP, and Outlook 2003 *only* Option Explicit Public Type ContactCandidates ' custom data type used to pack recipient name and RecipName As String ' email address into one element of a one-dimensional RecipAddress As String ' array End Type Public Declare Function RegCloseKey Lib "advapi32.dll" _ (ByVal hKey As Long) As Long Public Declare Function RegCreateKey Lib "advapi32.dll" _ Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _ As String, phkResult As Long) As Long Public Declare Function RegSetValueEx Lib "advapi32.dll" _ Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _ lpValueName As String, ByVal Reserved As Long, ByVal _ dwType As Long, lpData As Any, ByVal cbData As Long) As Long Public Candidates() As ContactCandidates ' dynamic array that stores the recipients as they ' are read from the Mail item Public NumCandidates As Long ' simple count of recipients read off the Mail item Public strMCL As String ' semicolon-delimited Master Category List Public MCL As Variant ' used to store array of Master Category List entries Public Const HKEY_CLASSES_ROOT = &H80000000 ' public constants used to facilitate use Public Const HKEY_CURRENT_USER = &H80000001 ' of Registry-related APIs Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const HKEY_USERS = &H80000003 Public Const HKEY_CURRENT_CONFIG = &H80000005 Public Const HKEY_DYN_DATA = &H80000006 Public Const REG_SZ = 1 Public Const REG_BINARY = 3 Public Const REG_DWORD = 4 Public Const ERROR_SUCCESS = 0& Sub AutoCreateContacts() Dim objMailItem As Outlook.MailItem, _ objRecipientList As Outlook.Recipients, _ objRecipient As Outlook.Recipient, _ objReply As Outlook.MailItem, _ strIncludeType As String, _ bolFrom As Boolean, _ bolTo As Boolean, _ bolCC As Boolean, _ bolBCC As Boolean, _ strCompany As String, _ Counter As Long, _ UseCategories As String ' Call UDF to grab Master Category List info from Registry. UDF returns a semicolon-delimited list; ' if the function had no problems, use Split() to populate MCL with individual entries strMCL = GetMCL() If LCase(Left(strMCL, 6)) <> "error:" Then MCL = Split(strMCL, ";") On Error GoTo ErrHandler ' Make sure the current item is a Mail item; if it is not, an error will be thrown and the error ' handler will be invoked Set objMailItem = Application.ActiveInspector.CurrentItem ' Show UserForm for setup (use To, From, CC, and/or BCC; Company; Categories). If UserForm is used ' successfully (Else condition), use control value to populate variables With frm1AutoCreateContacts .Show If .CancelButton.Cancel Then MsgBox "Operation canceled by user", vbCritical Unload frm1AutoCreateContacts GoTo Cleanup Else bolFrom = .CheckBox1.Value bolTo = .CheckBox2.Value bolCC = .CheckBox3.Value bolBCC = .CheckBox4.Value strCompany = .TextBox1.Value If Not IsEmpty(MCL) Then For Counter = 0 To (.ListBox1.ListCount - 1) UseCategories = UseCategories & _ IIf(.ListBox1.Selected(Counter), .ListBox1.List(Counter, 0) & ",", "") Next End If If Len(UseCategories) > 0 Then UseCategories = Left(UseCategories, Len(UseCategories) - 1) Else UseCategories = "" End If End If End With Unload frm1AutoCreateContacts ' Initialize variable. Since the array that holds the candidates will be zero-based, we need ' the variable to start at 0. Initialize to -1 because we increment this counter each time we ' touch a recipient (thus first recipient will get us to 0) NumCandidates = -1 Set objRecipientList = objMailItem.Recipients ' If we are getting the person sending the message, create a phony reply message to grab the ' "recipient" If bolFrom Then Set objReply = objMailItem.Reply PopulateCandidatesArray objReply.Recipients(1) End If ' Look at each true recipient in the Mail item. If the type is one we chose to include on the ' first UserForm, then use PopulateCandidatesArray to pass the recipient's info to the candidate ' array For Each objRecipient In objRecipientList Select Case objRecipient.Type Case olTo If bolTo Then PopulateCandidatesArray objRecipient End If Case olCC If bolCC Then PopulateCandidatesArray objRecipient End If Case olBCC If bolBCC Then PopulateCandidatesArray objRecipient End If End Select Next ' UserForm shows all recipients of valid types. Only the recipients the user selects will be ' turned into Contacts. By default, all recipients are selected at first With frm2AutoCreateContacts .Show If .CancelButton.Cancel Then MsgBox "Operation canceled by user", vbCritical Unload frm2AutoCreateContacts GoTo Cleanup Else For Counter = 0 To NumCandidates If .ListBox1.Selected(Counter) Then CreateNewContact Candidates(Counter).RecipName, _ Candidates(Counter).RecipAddress, strCompany, UseCategories Next End If End With Unload frm2AutoCreateContacts GoTo Cleanup ErrHandler: MsgBox "This procedure can only be run if a Mail item is currently active.", vbCritical Cleanup: On Error GoTo 0 Set objReply = Nothing Set objRecipient = Nothing Set objRecipientList = Nothing Set objMailItem = Nothing End Sub Private Sub CreateNewContact(strName As Variant, strAddress As Variant, _ Optional strCompany As String = "", Optional strCats As String = "") ' Sub uses info in arguments to create new Contact item Dim objContact As Outlook.ContactItem Set objContact = Application.CreateItem(olContactItem) With objContact .FullName = strName .Email1Address = strAddress .CompanyName = strCompany .Categories = strCats .Save End With Set objContact = Nothing End Sub Public Function EvaluateRecipientName(TestName As String) ' Function looks at recipient name. If it "looks like an email address" (i.e., if it has an ' "@" character), then it first eliminates all text starting with the "@" symbol, then replaces ' periods and underscores with spaces. This is an attempt to make the recipient name look more ' like a "real name" If InStr(1, TestName, "@") > 0 Then EvaluateRecipientName = Left(TestName, InStr(1, TestName, "@") - 1) EvaluateRecipientName = Replace(EvaluateRecipientName, "_", " ") EvaluateRecipientName = Replace(EvaluateRecipientName, ".", " ") Else EvaluateRecipientName = TestName End If End Function Private Sub PopulateCandidatesArray(Recip As Recipient) ' Sub populates array of candidates for new Contact items. ' Increment candidate counter NumCandidates = NumCandidates + 1 ' If counter = 0, then we are on the first candidate, and thus there is no need to preserve any ' values. If counter > 0, there are previous values we need to preserve when redimensioning the ' array If NumCandidates = 0 Then ReDim Candidates(0) As ContactCandidates Else ReDim Preserve Candidates(0 To NumCandidates) As ContactCandidates End If ' Populate latest array element Candidates(NumCandidates).RecipAddress = Recip.Address Candidates(NumCandidates).RecipName = EvaluateRecipientName(Recip.Name) End Sub Public Function GetMCL() As Variant ' Function returns a semicolon-delimited string that is the Master Category List. Use the VBA ' function Split() to break up the list into individual category items Dim arrVersion As Variant, _ objShell As Object, _ arrTemp As Variant, _ intCounter As Integer, _ strBuffer As String On Error GoTo ErrHandler Set objShell = CreateObject("Wscript.Shell") arrVersion = Split(Application.Version, ".") ' Outlook 2000 Master Category List is stored as regular text, but starting in XP the format changed. ' The Select Case statement branches the code to the appropriate handling, based on the user's ' version of Outlook Select Case arrVersion(0) Case 9 '2000 GetMCL = objShell.RegRead("HKCU\Software\Microsoft\Office\9.0\Outlook\Categories\MasterList") Case 10, 11 'XP/2003 arrTemp = objShell.RegRead("HKCU\Software\Microsoft\Office\" & arrVersion(0) & ".0\Outlook\Categories\MasterList") For intCounter = LBound(arrTemp) To UBound(arrTemp) If arrTemp(intCounter) <> 0 Then strBuffer = strBuffer & Chr(arrTemp(intCounter)) End If Next GetMCL = strBuffer Case Else GetMCL = "Error: Unknown Outlook Version" End Select GoTo Cleanup ErrHandler: GetMCL = "Error: Registry key not found" Cleanup: On Error GoTo 0 Set objShell = Nothing End Function Public Function WriteBinaryValue(ByVal lngHKey As Long, ByVal strPath As String, _ ByVal strValueName As String, bytArray() As Byte) As Boolean ' Starting with Outlook XP, Master Category List is stored as binary. This UDF handles adding ' a new item to the MCL for Outlook XP and later Dim lngResult As Long, _ lngCurKey As Long WriteBinaryValue = True lngResult = RegCreateKey(lngHKey, strPath, lngCurKey) If lngResult <> 0 Then WriteBinaryValue = False Else lngResult = RegSetValueEx(lngCurKey, strValueName, _ 0&, REG_BINARY, bytArray(0), UBound(bytArray()) + 1) If lngResult <> 0 Then WriteBinaryValue = False End If lngResult = RegCloseKey(lngCurKey) End If End Function Public Function AddItemToMCL(varItem As Variant) As Boolean ' Adds one item to the Master Category List. If the process succeeds, function returns True; ' if it fails, function returns False Dim arrVersion As Variant, _ objShell As Object, _ strBuffer As String, _ varKey As Variant, _ strPath As String, _ strValue As String, _ bolResult As Boolean, _ bytArray() As Byte On Error GoTo ehAddItemToMCL ' Get current Master Category List. If proposed new item is already in the MCL, don't add another ' copy. If it's new, then add it. (Test to see if new item is already in MCL is complex. Simple ' InStr() test may yield false result if proposed new item looks like a substring of an existing ' item. TO get around that, test separately for matches to first and last MCL entries and middle ' MCL entries strBuffer = GetMCL() If StrComp(Left(strBuffer, InStr(1, strBuffer, ";") - 1), varItem, vbTextCompare) = 0 Or _ StrComp(Mid(strBuffer, InStrRev(strBuffer, ";") + 1, Len(varItem)), varItem) = 0 Or _ InStr(1, strBuffer, ";" & varItem & ";", vbTextCompare) > 0 Then bolResult = False Else strBuffer = strBuffer & ";" & varItem & vbNullChar arrVersion = Split(Application.Version, ".") varKey = "HKCU" strValue = "MasterList" strPath = "Software\Microsoft\Office\" & arrVersion(0) & ".0\Outlook\Categories" Select Case arrVersion(0) Case 9 '2000 Set objShell = CreateObject("Wscript.Shell") objShell.RegWrite varKey & "\" & strPath & "\" & strValue, strBuffer, "REG_SZ" Set objShell = Nothing bolResult = True Case 10, 11 'XP/2003 bytArray = strBuffer bolResult = WriteBinaryValue(HKEY_CURRENT_USER, strPath, strValue, bytArray) Case Else bolResult = False End Select End If AddItemToMCL = bolResult Exit Function ehAddItemToMCL: AddItemToMCL = False Set objShell = Nothing End Function Sub TaskDueToday() Dim tsk As TaskItem Set tsk = Application.CreateItem(olTaskItem) With tsk .DueDate = Date .Display End With End Sub ' Code for class module frm1AutoCreateContacts Option Explicit Private Sub AddButton_Click() Dim NewCategory As String Dim Success As Boolean ' Ask user for possible new category NewCategory = InputBox("What new category do you want to add?", "Add Category") ' If none was given, cancel operation If Trim(NewCategory) = "" Then MsgBox "Action canceled by user", vbCritical, "Add New Category" Exit Sub End If ' UDF tries to add new category. Boolean return value indicates success or failure. If it succeeds, ' tell user, then get MCL and split it into array (held in public variable). Run SetUpForm to ' force category ListBox to refresh. If it fails, tell user it failed Success = AddItemToMCL(NewCategory) If Success Then With Me.ListBox1 .AddItem NewCategory .Selected(.ListCount - 1) = True End With MsgBox "New category '" & NewCategory & "' added. It will show up" & Chr(10) & _ "at the end of the category listbox.", vbOKOnly, "Add New Category" Else MsgBox "Failure: New category '" & NewCategory & "' not added", vbCritical, "Add New Category" End If End Sub Private Sub CancelButton_Click() Me.Hide End Sub Private Sub CheckBox1_Change() EvaluateCheckBoxes End Sub Private Sub CheckBox2_Change() EvaluateCheckBoxes End Sub Private Sub CheckBox3_Change() EvaluateCheckBoxes End Sub Private Sub CheckBox4_Change() EvaluateCheckBoxes End Sub Private Sub OKButton_Click() With Me .CancelButton.Cancel = False .Hide End With End Sub Private Sub UserForm_Initialize() SetUpForm End Sub Private Sub SetUpForm() Dim x As Variant With Me .CheckBox1.Value = True ' From .CheckBox2.Value = False ' To .CheckBox3.Value = False ' CC .CheckBox4.Value = False ' BCC .TextBox1.Value = "" ' Company .CancelButton.Cancel = True .OKButton.Enabled = True .OKButton.Default = True .ListBox1.Clear ' Wipe ListBox clean. If the Master Category List is If IsEmpty(MCL) Then ' available, populate ListBox with it. If not, then .ListBox1.Enabled = False ' disable ListBox .AddButton.Enabled = False Else .ListBox1.Enabled = True For Each x In MCL If Trim(x) <> "" Then .ListBox1.AddItem x Next .AddButton.Enabled = True End If End With End Sub Private Sub EvaluateCheckBoxes() ' If no CheckBoxes are checked, then disable OK button (user has to hit Cancel to clear form). ' If at least one CheckBox is checked, then enable OK Dim Counter As Long, Result As Long With Me For Counter = 1 To 4 Result = Result + .Controls("CheckBox" & Counter) Next If Result = 0 Then .OKButton.Default = False .OKButton.Enabled = False Else .OKButton.Default = True .OKButton.Enabled = True End If End With End Sub ' Code for class module frm2AutoCreateContacts Option Explicit Private Sub CancelButton_Click() Me.Hide End Sub Private Sub ListBox1_Change() Dim Counter As Long With Me For Counter = 0 To (.ListBox1.ListCount - 1) If .ListBox1.Selected(Counter) Then .OKButton.Enabled = True .OKButton.Default = True Exit Sub End If Next .OKButton.Enabled = False .OKButton.Default = False End With End Sub Private Sub OKButton_Click() With Me .CancelButton.Cancel = False .Hide End With End Sub Private Sub UserForm_Initialize() Dim Counter As Long With Me .CancelButton.Cancel = True For Counter = LBound(Candidates) To UBound(Candidates) .ListBox1.AddItem Candidates(Counter).RecipName & " | " & Candidates(Counter).RecipAddress .ListBox1.Selected(Counter) = True Next .OKButton.Enabled = True .OKButton.Default = True End With End Sub

How to use:

  1. Download the ZIP file for this KB entry
  2. Extract the contents of the ZIP file to your hard disk
  3. From Outlook, enter the Visual Basic Editor (Alt-F11)
  4. In the Project Explorer, right-click on the project VbaProject.OTM and select Import File from the popup menu. Select the file modAutoCreateContacts.bas (extracted from the ZIP file) for import
  5. Repeat process for files frm1AutoCreateContacts.frm and frm2AutoCreateContacts.frm
  6. Select the icon for VbaProject.OTM, and save the project
  7. Close the VBE
 

Test the code:

  1. Open an email message in Outlook
  2. Hit Alt-F8, and select AutoCreateContacts to run
  3. Choose what recipient types to include, and make optional Company and/or Category assignments. To make multiple Category assignments, hold down the Ctrl key
  4. The macro will now evaluate the recipients, and present you with a list of new Contact "candidates". Select which ones you want to make new Contact items for.
  5. Check your Contacts folder to ensure the Contacts were created correctly. Edit other Contact info, if needed
 

Sample File:

AutoCreateContacts.zip 8.39KB 

Approved by mdmackillop


This entry has been viewed 238 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express