AutoNumber Outlook Contacts

Introduction:

Why AutoNumber and how it works:

Outlook is a great contact management system. It lacks in a few places, but by using some of the power of the other Office tools, we can make up for the short comings. While the EntryID does offer you a unique ID to work with, there are a couple of problems. It's too long and it changes if you move your contacts from one folder to another. During the process of creating the unique ID we are also creating a record in Access with some basic Contact information. The combination of the Unique ID and the Access table now can serve a couple of purposes.

• It can link other ODBC datasources back to the Outlook contact store
• The Access table can serve as a fast source of data for combo boxes and list boxes
• It can allow you to extend Outlook by linking it to other ODBC datasources

Creating the unique ID is simple. Add a record to an Access table that has an AutoNumber field. When the record is added, grab the AutoNumber value using Select MAX and store it in a field in the Contact database. Check out the subroutine AssignNumber to see how this is done.

A few other examples:

Instuctions:

1. Create a TEST Contacts Folder. You can put some contacts in it or leave it empty
2. Unzip to file Autonumber.ZIP into any directory. You should have AutoNumber.OFT and AutoNumber.MDB
3. Register the Autonumber.MDB file as a system DSN. Call it Autonumber. You can do this through Control Panel - ODBC
4. Open the Autonumber.OFT file by double clicking
5. Select Disable Macros. Examine the code. This practice. Never run a macro until you've looked at the code
6. Choose File - Publish Form As and publish the form to your TEST Contacts Directory
7. You can close the Autonumber.OFT file or leave it open
8. Do a View - Folder List in Outlook
9. Right mouse click the TEST Contacts folder. Select Forms - Only forms listed above. You should see AutoNumber Contact Form
10. Open a Contact or create a new Contact. If you registered the MDB file correctly, you should not get an error. Make sure the listbox is populated and the different controls work

When you save the contact, you should see a message box with the new contact number. (Note: No number will be generated if there is no company name)

Email Don.Adams@USEast.Net if you have any problems.

Link to Autonumber.ZIP

Here is the code:

'Force explicit variable declaration
Option Explicit

'Remove comment from stop only if you want to step execution of code
'Stop

'Script level declarations
'Remember that in VBScript the AS keyword and typed variables
'are not allowed. All variables are typed as variant by default.

Dim dbe
Dim wrkODBC
Dim conDB
Dim Rs
Dim gstrAppName
Dim IsLoading
Dim mAnswer
Dim mSaveIt
Dim strSQL
Dim i
Dim MyArray()

'Dim page objects and controls collections

Dim objPage
Dim ObjLeads
Dim objControls

'Dim all controls on the form
Dim txtDiscount
Dim txtCustomerID
Dim txtCompany
Dim Frame1
Dim OptionButton1
Dim OptionButton2
Dim OptionButton3
Dim OptionButton4
Dim OptionButton5
Dim ComboBox1
Dim ListBox1
Dim CommandButton1
Dim CommandButton2
Dim LeadSourceCode
Dim LeadSourceDescription
Dim TextBox1

'Application Name
gstrAppName = "USEast Quoting System"

'Remember that DAO constants must be dimmed and set.
'They cannot be called directly as you would in VB or VBA.

Dim dbUseODBC
Dim dbDriverComplete
Dim dbDriverNoPrompt
Dim dbDriverPrompt
Dim dbDriverCompleteRequired
Dim dbOpenSnapshot
Dim dbOpenForwardOnly
Dim dbOpenDynamic
Dim dbOptimistic

'Important-You must assign constants for arguments to DAO methods
'such as dbOpenSnapshot.

dbUseODBC=1
dbDriverComplete=0
dbDriverNoPrompt=1
dbDriverPrompt=2
dbDriverCompleteRequired=3
dbOpenSnapshot=4
dbOpenForwardOnly=8
dbOpenDynamic=16
dbOptimistic=3

mSaveit = True

'-----------------------------------------------------------------------------------------------
Function Item_Open

Set objPage = Item.GetInspector.ModifiedFormPages("Company Info")
Set objLeads = Item.GetInspector.ModifiedFormPages("Lead Sources")

Set objControls = objPage.Controls
Set txtDiscount = objControls("txtDiscount")
Set txtCustomerID = objControls("txtCustomerID")
Set txtCompany= objControls("txtCompany")
Set OptionButton1 = objControls("OptionButton1")
Set OptionButton2 = objControls("OptionButton2")
Set OptionButton3 = objControls("OptionButton3")
Set OptionButton4 = objControls("OptionButton4")
Set OptionButton5 = objControls("OptionButton5")
Set Frame1 = objControls("Frame1")
Set Listbox1=ObjLeads.Controls("Listbox1")
Set Textbox1=ObjLeads.Controls("Textbox1")
Set LeadSourceCode=ObjLeads.Controls("LeadSourceCode")
Set LeadSourceDescription=ObjLeads.Controls("LeadSourceDescription")
Set CommandButton1=ObjLeads.Controls("CommandButton1")
Set CommandButton2=ObjLeads.Controls("CommandButton2")
Set ComboBox1=ObjLeads.Controls("ComboBox1")

mSaveit = True

'Use the GetODBCConnection function to establish an ODBC Connection

If Not (GetODBCConnection("AutoNumber","ODBC;DSN=AutoNumber", _
dbDriverCompleteRequired)) Then
End If

' Fill the Lead Source List Box
FillListBox
' Fill Lead Source Type ComboBox
FillLeadSourceType
ComboBox1.ListIndex = 0 'Set combo box to first entry

end Function


'-----------------------------------------------------------------------------------------------
Sub FillListBox()

strSQL = "Select * from [Lead Sources Query];"

Set RS = conDB.OpenRecordset(strSQL, dbOpenSnapshot)

RS.MoveLast
RS.MoveFirst

Redim MyArray(RS.RecordCount-1,3)

ListBox1.ColumnCount = 3 'This list box contains 3 data columns
ListBox1.BoundColumn = 1
ListBox1.Clear

for i = 0 to RS.RecordCount - 1

MyArray(i, 0) = RS(0)
MyArray(i, 1) = RS(1)
MyArray(i, 2) = RS(2)

RS.MoveNext

next

ListBox1.List() = MyArray

End Sub

'-----------------------------------------------------------------------------------------------
Sub FillLeadSourceType()

strSQL = "Select * from [Lead Source Type Query];"

Set RS = conDB.OpenRecordset(strSQL, dbOpenSnapshot)

RS.MoveLast
RS.MoveFirst

Redim MyArray(RS.RecordCount-1)

for i = 0 to RS.RecordCount - 1

MyArray(i) = RS(0)

RS.MoveNext

next

ComboBox1.List() = MyArray

End Sub


'-----------------------------------------------------------------------------------------------
Function Item_Write()

if mSaveit = False then
Item_Write = False
else
Item_Write = True
end if

end Function


'-----------------------------------------------------------------------------------------------
Function Item_Close()

if txtCustomerID.Text = "" and txtCompany.Text <> "" then

if Not Item.Saved then

mAnswer = msgbox("Do you wish to save changed info and assign CustomerID number",vbYesNo)

if mAnswer = vbNo then
mSaveit = False
Exit Function
else
mSaveit = True
Item.Save
end if

end if

AssignNumber

end if

End Function


'-----------------------------------------------------------------------------------------------
Sub AssignNumber()

'Dim procedure variables.
Dim curExtension
Dim lngCustomerID
Dim mQuote

mQuote = chr(34)

'Error trapping-remove this statement if you are debugging
On Error Resume Next

'Set this variable to True to indicate loading state
IsLoading = True

if txtCustomerID.Text = "" and item.CompanyName <> "" then

strSQL = "Insert Into [Customers] ([Company Name], [Contact Name], [EntryID], [Categories]) "
strSQL = strSQL & "Values ('" & item.CompanyName
strSQL = strSQL & "','" & item.FullName
strSQL = strSQL & "','" & item.EntryID
strSQL = strSQL & "','" & item.Categories
strSQL = strSQL & "');"

conDB.Execute strSQL

If Err.Number <> 0 Then
Msgbox "Error#: " & err.number & chr(13) & err.description
End if

strSQL = "Select Max(CompanyID) from Customers" ' Find highest ID Number

Set RS = conDB.OpenRecordset(strSQL)
lngCustomerID = RS(0)

msgbox "The CustomerID is " & trim(cstr(lngCustomerID))

RS.Close

Item.CustomerID = trim(cstr(lngCustomerID))

mSaveit = True
item.save

end if

End Sub


'-----------------------------------------------------------------------------------------------
Function GetODBCConnection (ByVal MyDSN, ByVal MyConn, ByVal MyPrompt)
Dim strUser
Dim strPass
Dim dbUseODBC
'Must assign values to constants in VBScript
dbUseODBC = 1
'Turn on error trappping
On Error Resume Next
'Set to defaults-change these values if required
strUser = "admin"
strPass = ""
'Create a DAO object. You must use DAO.dbEngine.35 or you will cause
'a page fault on machines with both DAO 3 and DAO 3.5 installed.
Set dbe = Item.Application.CreateObject("DAO.dbEngine.35")
If Err.Number <> 0 Then
Msgbox "Error#: " & err.number & chr(13) & err.description & chr(13) _
& "Warning -- Could not create DAO 3.5 Object!" & Chr(13) _
& "Please make sure that DAO 3.5 is installed on this machine!", _
16, gstrAppName
GetODBCConnection = False
Exit Function
End If
'Create an ODBCDirect Workspace
Set wrkODBC = dbe.CreateWorkspace("ODBCWorkspace", strUser, strPass , dbUseODBC)
If Err.Number <> 0 Then

Msgbox "Error#: " & err.number & chr(13) & err.description & chr(13) _
& "Warning -- Could not create ODBC workspace!" & chr(13) _
& "Please make sure that user name and password are correct.", 16, _
gstrAppName
GetODBCConnection = False
Exit Function
End If
dbe.Workspaces.Append wrkODBC
'Establish the connection to DSN
Set conDB = wrkODBC.OpenConnection("Connection1", MyPrompt, , MyConn)
If Err.Number <> 0 Then
Msgbox "Error#: " & err.number & chr(13) & err.description & chr(13) _
& "Warning -- Could not create connection to " & MyDSN & "!" & chr(13) _
& "Please make sure that " & MyDSN & " is a valid DSN!", 16, _
gstrAppName
GetODBCConnection = False
Exit Function
End If
GetODBCConnection = True
End Function



'-----------------------------------------------------------------------------------------------
Sub Item_CustomPropertyChange(ByVal Name)

Select Case Name

Case "CustomerCategory" ' The Radio button

'msgbox "Customer Category is " & Item.UserProperties("CustomerCategory").Value

Select Case Item.UserProperties("CustomerCategory").Value
Case ""
txtDiscount.Value = "0%"
Case "End User/GSA"
txtDiscount.Value = "10%"
Case "OEM"
txtDiscount.Value = "20%"
Case "VAR/SI"
txtDiscount.Value = "30%"
Case "OEM"
txtDiscount.Value = "40%"
Case "Other"
txtDiscount.Value = "0%"
End Select


End Select

End Sub

'-----------------------------------------------------------------------------------------------
Sub Item_PropertyChange(ByVal Name)

'msgbox "Property is " & Name

Select Case Name

Case "CompanyName"

'stop
'txtCompany = Item.CompanyName.Text
'MsgBox "The active item is " & ActiveInspector.CurrentItem.CompanyName

End Select

End Sub

'-----------------------------------------------------------------------------------------------
Sub CommandButton1_Click()

if TextBox1.Text = "" then
TextBox1.Text = ListBox1.Value
else
TextBox1.Text = TextBox1.Text & "," & ListBox1.Value
end if

End Sub

'-----------------------------------------------------------------------------------------------
Sub CommandButton2_Click()

'Msgbox "Feature not yet available"
SaveNewLeadSource

End sub

'-----------------------------------------------------------------------------------------------
Sub Listbox1_Click()

CommandButton1.Caption = "Add " & ListBox1.Value & " To List"

End sub

'-----------------------------------------------------------------------------------------------
Sub SaveNewLeadSource()

If LeadSourceCode.Text = "" then

msgbox "Lead Source Code cannot be blank"
exit sub

end if

If Len(LeadSourceCode.Text) <> 4 then

msgbox "Lead Source Code Must be 4 Characters"
exit sub

end if


If LeadSourceDescription.Text = "" then

msgbox "Lead Source Description cannot be blank"
exit sub

end if

If ComboBox1.Text = "" then

msgbox "Lead Source Type cannot be blank"
exit sub

end if

' Validate the data

strSQL = "Select [Lead Sources].[Lead Source Code] from [Lead Sources] "
strSQL = strSQL & "WHERE ((([Lead Sources].[Lead Source Code])='" & Trim(LeadSourceCode.Text) & "'));"
Set RS = conDB.OpenRecordset(strSQL, dbOpenSnapshot)

msgbox CStr(RS.RecordCount)

if RS.RecordCount > 0 then

msgbox "Lead Source Code " & Trim(LeadSourceCode.Text) & " Already Exists"
exit sub

End if

strSQL = "Insert Into [Lead Sources] ([Lead Source Code], [Lead Source Description], [Lead Source Type]) "
strSQL = strSQL & "Values ('" & LeadSourceCode.Text
strSQL = strSQL & "','" & LeadSourceDescription.Text
strSQL = strSQL & "','" & ComboBox1.Text
strSQL = strSQL & "');"

On Error Resume Next
conDB.Execute strSQL

If Err.Number <> 0 Then
Msgbox "Error#: " & err.number & chr(13) & err.description
Else
MsgBox "New Lead Source " & LeadSourceDescription.Text & " Was Saved Successfully."
End if

End Sub

'-----------------------------------------------------------------------------------------------