FrustratedPgmr
Programmer
I am trying to add 2 combo boxes to a toolbar. I get the combo boxes created but the second combo box just "dings" when I click on it.
The comboboxes are 1(PatName)
(Findrowinactivecontrol3 function finds the current record based on the name)
and 2(PatSSN)
(findrowinactivecontrol4 function finds the current record based on the ssn number)
I want to set the current record to the name or the ssn depending on which one I click.
The first box works fine the second doesn't load the ssn# data and only dings when I click on it.
******************************************************
create the commandbar called "Patients"
*******************************************************
Option Compare Database
Option Explicit
Private mcolFound As Collection
Dim rst As DAO.Recordset
Dim cbr As CommandBar
Dim ctl As CommandBarControl
'Delete the toolbar if it exists and recreate with new records in dropdown box
For Each cbr In Application.CommandBars
If cbr.Name = "Patients" Then
cbr.Delete
End If
Next cbr
' Create the new commandbar.
Set cbr = CommandBars.Add("Patients", Position:=msoBarTop, Temporary:=True)
cbr.Visible = True
cbr.Protection = msoBarNoMove
Set ctl = cbr.Controls.Add(Type:=msoControlDropdown, before:=1)
With ctl
.Tag = "PatientID"
.Caption = "Select Patient &Lastname:"
.style = msoComboLabel
' Use the default width for the dropdown.
.DropDownWidth = -1
Set rst = Forms!frmPT.RecordsetClone
Do While Not rst.EOF
.AddItem rst("PatName"
rst.MoveNext
Loop
' Although you could specify
' the OnAction property here,
' you can use WithEvents to
' trap the events of the combo box
' instead. This allows you more
' flexibility.
.OnAction = "FindRowInActiveControl3"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlDropdown, before:=2)
With ctl
.Tag = "PatientSS"
.Caption = "Select Social Sec:"
.style = msoComboLabel
' Use the default width for the dropdown.
.DropDownWidth = -1
Set rst = Forms!frmPT.RecordsetClone
Do While Not rst.EOF
.AddItem rst("PatSS"
rst.MoveNext
Loop
' Although you could specify
' the OnAction property here,
' you can use WithEvents to
' trap the events of the combo box
' instead. This allows you more
' flexibility.
.OnAction = "FindRowInActiveControl4"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlButton)
With ctl
.BeginGroup = True
.Caption = "&Help"
.style = msoButtonCaption
.OnAction = "OpnPatHelp"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlButton)
With ctl
.BeginGroup = True
.Caption = "&Exit"
.style = msoButtonCaption
.OnAction = "PatClose"
End With
End Function
********************************************
*Functions used by the commandbar "Patients"
********************************************
Public Function FindRowInActiveControl3()
' Function called from the OnAction property of the
' frmPT commandbar.
' Recordsets behind forms in MDB files
' must be DAO recordsets, not ADO.
Dim rst As DAO.Recordset
Dim strID As String
Dim cbc As CommandBarComboBox
Set cbc = CommandBars.ActionControl
strID = cbc.Text
If Len(strID) > 0 Then
With Forms!frmPT
'With Screen.ActiveForm
Set rst = Forms!frmPT.RecordsetClone
rst.FindFirst "PatName = " & FixQuotes(strID)
'rst.FindFirst "LastName = " & FixQuotes(strID)
If Not rst.NoMatch Then
.Bookmark = rst.Bookmark
Call AddToListHeader(cbc)
End If
cbc.ListIndex = 0
End With
End If
End Function
Public Function FindRowInActiveControl4()
' Function called from the OnAction property of the frmPT
' commandbar.
' Recordsets behind forms in MDB files
' must be DAO recordsets, not ADO.
Dim rst As DAO.Recordset
Dim strID As String
Dim cbc As CommandBarComboBox
Set cbc = CommandBars.ActionControl
strID = cbc.Text
If Len(strID) > 0 Then
With Forms!frmPT
'With Screen.ActiveForm
Set rst = Forms!frmPT.RecordsetClone
rst.FindFirst "PatSS = " & FixQuotes(strID)
'rst.FindFirst "LastName = " & FixQuotes(strID)
If Not rst.NoMatch Then
.Bookmark = rst.Bookmark
Call AddToListHeader(cbc)
End If
cbc.ListIndex = 0
End With
End If
End Function
******************************************************
*adds your selection to the top of the combo box list
******************************************************
Private Function AddToListHeader( _
cbc As CommandBarComboBox) As Boolean
' Add item to the header of the list if it's
' not already there, and return True if the
' item got added.
On Error Resume Next
Dim strID As String
' If this is the first time through here,
' you'll need to instantiate this Collection object.
If mcolFound Is Nothing Then
Set mcolFound = New Collection
End If
' Get the selected text and
' add it to the internal collection of values.
' If it's already in the list, Err.Number
' will be non-zero.
strID = cbc.Text
mcolFound.Add strID, Key:=strID
' Yes, this code should be smarter about errors.
' It's only example code!
If err.Number <> 0 Then
AddToListHeader = False
Else
' Add the ID to the combo box on the command bar.
' Always add it at the top of the list.
Call cbc.AddItem(strID, 1)
' The ListHeaderCount will be -1 the first time
' you come through here, indicating no divider
' line at all. If ListHeaderCount is 0, you
' have a divider line with nothing above it.
' This code either increments the value of the
' property, or sets it to be 1 in the first place.
If cbc.ListHeaderCount > 0 Then
cbc.ListHeaderCount = cbc.ListHeaderCount + 1
Else
cbc.ListHeaderCount = 1
End If
AddToListHeader = True
End If
End Function
**********************************************************
Private Function FixQuotes(varValue As Variant)
' Double any quotes inside varValue, and
' surround it with quotes.
' From Access 2002 Desktop Developer's Handbook
' by Litwin, Getz, Gunderloy (Sybex)
' Copyright 2001. All rights reserved.
FixQuotes = "'" & Replace$(varValue & "", "'", "''", Compare:=vbTextCompare) & "'"
End Function
*********************************************************
Public Sub ClearCollection()
Set mcolFound = Nothing
End Sub
The comboboxes are 1(PatName)
(Findrowinactivecontrol3 function finds the current record based on the name)
and 2(PatSSN)
(findrowinactivecontrol4 function finds the current record based on the ssn number)
I want to set the current record to the name or the ssn depending on which one I click.
The first box works fine the second doesn't load the ssn# data and only dings when I click on it.
******************************************************
create the commandbar called "Patients"
*******************************************************
Option Compare Database
Option Explicit
Private mcolFound As Collection
Dim rst As DAO.Recordset
Dim cbr As CommandBar
Dim ctl As CommandBarControl
'Delete the toolbar if it exists and recreate with new records in dropdown box
For Each cbr In Application.CommandBars
If cbr.Name = "Patients" Then
cbr.Delete
End If
Next cbr
' Create the new commandbar.
Set cbr = CommandBars.Add("Patients", Position:=msoBarTop, Temporary:=True)
cbr.Visible = True
cbr.Protection = msoBarNoMove
Set ctl = cbr.Controls.Add(Type:=msoControlDropdown, before:=1)
With ctl
.Tag = "PatientID"
.Caption = "Select Patient &Lastname:"
.style = msoComboLabel
' Use the default width for the dropdown.
.DropDownWidth = -1
Set rst = Forms!frmPT.RecordsetClone
Do While Not rst.EOF
.AddItem rst("PatName"
rst.MoveNext
Loop
' Although you could specify
' the OnAction property here,
' you can use WithEvents to
' trap the events of the combo box
' instead. This allows you more
' flexibility.
.OnAction = "FindRowInActiveControl3"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlDropdown, before:=2)
With ctl
.Tag = "PatientSS"
.Caption = "Select Social Sec:"
.style = msoComboLabel
' Use the default width for the dropdown.
.DropDownWidth = -1
Set rst = Forms!frmPT.RecordsetClone
Do While Not rst.EOF
.AddItem rst("PatSS"
rst.MoveNext
Loop
' Although you could specify
' the OnAction property here,
' you can use WithEvents to
' trap the events of the combo box
' instead. This allows you more
' flexibility.
.OnAction = "FindRowInActiveControl4"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlButton)
With ctl
.BeginGroup = True
.Caption = "&Help"
.style = msoButtonCaption
.OnAction = "OpnPatHelp"
End With
Set ctl = cbr.Controls.Add(Type:=msoControlButton)
With ctl
.BeginGroup = True
.Caption = "&Exit"
.style = msoButtonCaption
.OnAction = "PatClose"
End With
End Function
********************************************
*Functions used by the commandbar "Patients"
********************************************
Public Function FindRowInActiveControl3()
' Function called from the OnAction property of the
' frmPT commandbar.
' Recordsets behind forms in MDB files
' must be DAO recordsets, not ADO.
Dim rst As DAO.Recordset
Dim strID As String
Dim cbc As CommandBarComboBox
Set cbc = CommandBars.ActionControl
strID = cbc.Text
If Len(strID) > 0 Then
With Forms!frmPT
'With Screen.ActiveForm
Set rst = Forms!frmPT.RecordsetClone
rst.FindFirst "PatName = " & FixQuotes(strID)
'rst.FindFirst "LastName = " & FixQuotes(strID)
If Not rst.NoMatch Then
.Bookmark = rst.Bookmark
Call AddToListHeader(cbc)
End If
cbc.ListIndex = 0
End With
End If
End Function
Public Function FindRowInActiveControl4()
' Function called from the OnAction property of the frmPT
' commandbar.
' Recordsets behind forms in MDB files
' must be DAO recordsets, not ADO.
Dim rst As DAO.Recordset
Dim strID As String
Dim cbc As CommandBarComboBox
Set cbc = CommandBars.ActionControl
strID = cbc.Text
If Len(strID) > 0 Then
With Forms!frmPT
'With Screen.ActiveForm
Set rst = Forms!frmPT.RecordsetClone
rst.FindFirst "PatSS = " & FixQuotes(strID)
'rst.FindFirst "LastName = " & FixQuotes(strID)
If Not rst.NoMatch Then
.Bookmark = rst.Bookmark
Call AddToListHeader(cbc)
End If
cbc.ListIndex = 0
End With
End If
End Function
******************************************************
*adds your selection to the top of the combo box list
******************************************************
Private Function AddToListHeader( _
cbc As CommandBarComboBox) As Boolean
' Add item to the header of the list if it's
' not already there, and return True if the
' item got added.
On Error Resume Next
Dim strID As String
' If this is the first time through here,
' you'll need to instantiate this Collection object.
If mcolFound Is Nothing Then
Set mcolFound = New Collection
End If
' Get the selected text and
' add it to the internal collection of values.
' If it's already in the list, Err.Number
' will be non-zero.
strID = cbc.Text
mcolFound.Add strID, Key:=strID
' Yes, this code should be smarter about errors.
' It's only example code!
If err.Number <> 0 Then
AddToListHeader = False
Else
' Add the ID to the combo box on the command bar.
' Always add it at the top of the list.
Call cbc.AddItem(strID, 1)
' The ListHeaderCount will be -1 the first time
' you come through here, indicating no divider
' line at all. If ListHeaderCount is 0, you
' have a divider line with nothing above it.
' This code either increments the value of the
' property, or sets it to be 1 in the first place.
If cbc.ListHeaderCount > 0 Then
cbc.ListHeaderCount = cbc.ListHeaderCount + 1
Else
cbc.ListHeaderCount = 1
End If
AddToListHeader = True
End If
End Function
**********************************************************
Private Function FixQuotes(varValue As Variant)
' Double any quotes inside varValue, and
' surround it with quotes.
' From Access 2002 Desktop Developer's Handbook
' by Litwin, Getz, Gunderloy (Sybex)
' Copyright 2001. All rights reserved.
FixQuotes = "'" & Replace$(varValue & "", "'", "''", Compare:=vbTextCompare) & "'"
End Function
*********************************************************
Public Sub ClearCollection()
Set mcolFound = Nothing
End Sub