'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
|