The category selected from the combo box is not being saved with the contact
file.
I am not a visual basic expert and alot of this code was picked up from
other help forums and i don't understand it all. I can't figure out what's
going wrong here.
Please help
Here is my code so far:
' ******************* GLOBAL VARIABLES ***************************
Dim gstrRequiredCats
' ******************* FORM EVENTS ********************************
Dim mstrAppPath
Dim mfso
Function Item_Open()
Dim objInsp
Dim cmb
Dim colControls
On Error Resume Next
' full path to folder without trailing slash
mstrAppPath = "W:\OFFICE\Outlook 2003"
' for new item, read data from MRU list into combo boxes
Call InitAppPath
Set objInsp = Item.GetInspector
Set colControls = _
objInsp.ModifiedFormPages("Categories").Controls
Set cmb = colControls("ListBox1")
If Err = 0 Then
Call SetComboListFromFile("Job Categories2.txt", cmb)
Else
Err.Clear
End If
Set cmb = colControls("lstCategories")
If Err = 0 Then
Call SetComboListFromFile("Prof Categories.txt", cmb)
Else
Err.Clear
End If
Set cmb = Nothing
Set colControls = Nothing
' Change the string in the next line to the required categories
' you want to see on the Categories tab, separated by semicolons.
' These should be the same as the Possible Values set on the Value
' tab of the list box' Properties
gstrRequiredCats = (strtext)
' set required categories in label
Set objPage = Item.GetInspector.ModifiedFormPages("Categories")
Set objControl = objPage.Controls("lstCategories")
strLabel = "Before you can save this item, you must choose one or
more of the required categories from the Professional Categories List " & _
" one or more of these required
categories:" & vbCrLf
arrRCats = Split(gstrRequiredCats, ";")
For I = 0 to UBound(arrRCats)
strLabel = strLabel & vbCrLf & Space(10) & Trim(arrRCats(I))
Next
objPage.Controls("Label1").Caption = strLabel
' set category string to upper case for later testing
gstrRequiredCats = UCase(gstrRequiredCats)
End Function
Function Item_Write()
Dim objInsp
Dim colControls
Dim cmb
On Error Resume Next
Set objInsp = Item.GetInspector
Set colControls = _
objInsp.ModifiedFormPages("Categories").Controls
Set cmb = colControls("listbox1")
If Err = 0 Then
Call WriteMRUToFile("Job Categories.txt", cmb)
Else
Err.Clear
End If
Set cmb = Nothing
Set colControls = Nothing
Set objInsp = Nothing
End Function
' ******************************************************
' Routines for MRU combo boxes
' ******************************************************
Sub InitAppPath()
Dim lngLoc
Dim strParentPath
Dim strFolderName
' mstrAppPath set in Item_Open
' create new folder if necessary; code handles just
' two levels of folders
Set mfso = CreateObject("Scripting.FileSystemObject")
If Not mfso.FolderExists(mstrAppPath) Then
lngLoc = InStrRev(mstrAppPath, "\")
strParentPath = Left(mstrAppPath, lngLoc - 1)
strFolderName = Mid(mstrAppPath, lngLoc + 1)
If Not mfso.FolderExists(strParentPath) Then
mfso.CreateFolder strParentPath
End If
mfso.CreateFolder mstrAppPath
End If
' add trailing slash
mstrAppPath = mstrAppPath & "\"
End Sub
' read data from text file into combo box or list box
Sub SetComboListFromFile(strFileName, ctlList)
Dim strFilePath, strText
Dim f
Dim ts
Dim arr
strFilePath = mstrAppPath & strFileName
If mfso.FileExists(strFilePath) Then
Set f = mfso.GetFile(strFilePath)
Set ts = f.OpenAsTextStream
If Not ts.AtEndOfStream Then
strText = ts.ReadAll
If strText <> "" Then
arr = Split(strText, vbCrLf)
ctlList.List = arr
End If
End If
Else
Set f = mfso.CreateTextFile(strFilePath)
f.Close
End If
Set ts = Nothing
Set f = Nothing
End Sub
' add new entry to combo box MRU list
Sub WriteMRUToFile(strFileName, ctlCombo)
Dim arr ' array of combo box entries
Dim strFilePath, strText
Dim f
Dim i
Const ForReading = 1, ForWriting = 2, ForAppending = 8
On Error Resume Next
' see if we need to write data
If ctlCombo.Value <> "" And Not ctlCombo.MatchFound Then
' add item, get array, and sort
ctlCombo.AddItem ctlCombo.Value
arr = ctlCombo.List
QSort arr, LBound(arr), UBound(arr)
For i = 0 To UBound(arr)
strText = strText & vbCrLf & arr(i, 0)
Next
strText = Mid(strText, 3)
' get file to write to
strFilePath = mstrAppPath & strFileName
Set f = mfso.OpenTextFile(strFilePath, ForWriting, True)
f.Write strText
f.Close
End If
Set f = Nothing
End Sub
' recursive quick sort routine for combo box list
Sub QSort(aData, iaDataMin, iaDataMax)
Dim Temp
Dim Buffer
Dim iaDataFirst
Dim iaDataLast
Dim iaDataMid
iaDataFirst = iaDataMin
iaDataLast = iaDataMax
If iaDataMax <= iaDataMin Then Exit Sub
iaDataMid = (iaDataMin + iaDataMax) \ 2
Temp = aData(iaDataMid, 0)
Do While (iaDataFirst <= iaDataLast)
'Comparison here
Do While aData(iaDataFirst, 0) < Temp
iaDataFirst = iaDataFirst + 1
If iaDataFirst = iaDataMax Then Exit Do
Loop
'Comparison here
Do While Temp < aData(iaDataLast, 0)
iaDataLast = iaDataLast - 1
If iaDataLast = iaDataMin Then Exit Do
Loop
If (iaDataFirst <= iaDataLast) Then
Buffer = aData(iaDataFirst, 0)
aData(iaDataFirst, 0) = aData(iaDataLast, 0)
aData(iaDataLast, 0) = Buffer
iaDataFirst = iaDataFirst + 1
iaDataLast = iaDataLast - 1
End If
Loop
If iaDataMin < iaDataLast Then
QSort aData, iaDataMin, iaDataLast
End If
If iaDataFirst < iaDataMax Then
QSort aData, iaDataFirst, iaDataMax
End If
End Sub
Function Item_Write()
If HasRequiredCategory() = False Then
Item_Write = False
Item.GetInspector.SetCurrentFormPage "Categories"
Set objPage = Item.GetInspector.ModifiedFormPages("Categories")
Set objControl = objPage.Controls("lstCategories")
objControl.SetFocus
End If
End Function
' ***************************************************************
' Name: HasRequiredCategory
' Arguments: None
' Returns: True if item category matches a required category
' True if no required categories
' False if categories required, but no match
' ***************************************************************
Function HasRequiredCategory()
Set objPage = Item.GetInspector.ModifiedFormPages("Categories")
Set objControl = objPage.Controls("lstCategories")
If gstrRequiredCats <> "" Then
arrCats = Split(UCase(Item.Categories),",")
arrRequiredCats = Split(gstrRequiredCats,";")
For I = 0 To UBound(arrCats, 1)
For J = 0 To UBound(arrRequiredCats, 1)
If Trim(arrCats(I)) = Trim(arrRequiredCats(J)) Then
blnMatch = True
Exit For
End If
Next
If blnMatch = True Then
Exit For
End If
Next
Else
blnMatch = True
End If
HasRequiredCategory = blnMatch
End Function
*************************************************************
"Sue Mosher [MVP-Outlook]" wrote:
