Option Explicit
Public Type ContactCandidates
RecipName As String
RecipAddress As String
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
Public NumCandidates As Long
Public strMCL As String
Public MCL As Variant
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&
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
strMCL = GetMCL()
If LCase(Left(strMCL, 6)) <> "error:" Then MCL = Split(strMCL, ";")
On Error GoTo ErrHandler
Set objMailItem = Application.ActiveInspector.CurrentItem
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
NumCandidates = -1
Set objRecipientList = objMailItem.Recipients
If bolFrom Then
Set objReply = objMailItem.Reply
PopulateCandidatesArray objReply.Recipients(1)
End If
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
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 = "")
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)
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)
NumCandidates = NumCandidates + 1
If NumCandidates = 0 Then
ReDim Candidates(0) As ContactCandidates
Else
ReDim Preserve Candidates(0 To NumCandidates) As ContactCandidates
End If
Candidates(NumCandidates).RecipAddress = Recip.Address
Candidates(NumCandidates).RecipName = EvaluateRecipientName(Recip.Name)
End Sub
Public Function GetMCL() As Variant
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, ".")
Select Case arrVersion(0)
Case 9
GetMCL = objShell.RegRead("HKCU\Software\Microsoft\Office\9.0\Outlook\Categories\MasterList")
Case 10, 11
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
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
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
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
Set objShell = CreateObject("Wscript.Shell")
objShell.RegWrite varKey & "\" & strPath & "\" & strValue, strBuffer, "REG_SZ"
Set objShell = Nothing
bolResult = True
Case 10, 11
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
Option Explicit
Private Sub AddButton_Click()
Dim NewCategory As String
Dim Success As Boolean
NewCategory = InputBox("What new category do you want to add?", "Add Category")
If Trim(NewCategory) = "" Then
MsgBox "Action canceled by user", vbCritical, "Add New Category"
Exit Sub
End If
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
.CheckBox2.Value = False
.CheckBox3.Value = False
.CheckBox4.Value = False
.TextBox1.Value = ""
.CancelButton.Cancel = True
.OKButton.Enabled = True
.OKButton.Default = True
.ListBox1.Clear
If IsEmpty(MCL) Then
.ListBox1.Enabled = False
.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()
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
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
|