• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1556
  • Last Modified:

VBA code to add an item to the Master Category List

Dear Experts,

Over the past couple of days, I have been working on a utility that will automatically add recipients from email messages
as new Contacts.  The project started here:
http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21413779.html

and continued here (in which I learned how to grab the current Master Category List):
http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21417753.html

In both cases, I got great support from David (aka BlueDevilFan), but of course this question is open to all comers :)

To put the finishing touch on the project, I would like to be able to programmatically add one item to the Master
Category List.  This will have to work for Outlook 2000, Outlook XP, and Outlook 2003, as I envision distributing the
utility to users of all three applications.

Regards,

Patrick
0
Patrick Matthews
Asked:
Patrick Matthews
  • 2
  • 2
1 Solution
 
David LeeCommented:
Patrick,

This one was more difficult because WshShell's (Wscript.Shell) RegWrite method apparently cannot write a long binary value.  So, I had to switch and use a more complicated solution for writing the changed MCL back into the registry.  Anyway, here it is.  I tested it with Outlook 2003 and it worked fine there.  I suspect that means it'll work fine on 2002 also.  Not sure about 2000.  I think I have it right but have no means of testing it there.


Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
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&

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 Function WriteBinaryValue(ByVal lngHKey As Long, ByVal strPath As String, _
    ByVal strValueName As String, bytArray() As Byte) As Boolean
    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
        lRegResult = RegCloseKey(lngCurKey)
    End If
End Function

Private Function AddItemToMCL(varItem As Variant) As Boolean
    Dim arrVersion As Variant, _
        objShell As WshShell, _
        strBuffer As String, _
        varKey As Variant, _
        strPath As String, _
        strValue As String, _
        bolResult As Boolean, _
        bytArray() As Byte
    On Error GoTo ehAddItemToMCL
    strBuffer = GetMCL()
    If InStr(1, strBuffer, varItem) > 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
    Exit Function
End Function
0
 
Patrick MatthewsAuthor Commented:
David,

Cool!  I'll test it later.

I knew that this one was harder to do :)

Patrick
0
 
Patrick MatthewsAuthor Commented:
David,

Works like a charm.  I made some minor tweaks (such as made the search for the proposed new item in the existing list a tad
more sophisticated) and cleaned up a couple of minor points picked up on compile (one variable misspelled in WriteBinaryValue;
changed declaration of objShell in AddItemToMCL to Object).

The updated module and UserForms are available at:
www.geocities.com/matthewspatrick/AutoCreateContacts.zip

Thank you so much for your help!

Patrick
0
 
David LeeCommented:
Patrick,

Oops.  I'd meant to change objShell's declaration but obviously forgot.  Glad it worked out.  I'll grab the final product and have a look when I get a minute.

No problem.  Glad I was able to help.

Take care.

-- David
0

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now