Solved

Type Mismatch with AddAlltoList

Posted on 2009-03-31
3
528 Views
Last Modified: 2012-05-06
I get the AddAlltoList function (http://support.microsoft.com/?kbid=210290) to work fine in Access 2007 but in Access 2003 I get a "Type Mismatch" error at the line:

Set RS = DB.OpenRecordset(C.RowSource, DB_OPEN_SNAPSHOT)

I added AddAlltoList as the RowSourceType of a multiselect listbox with Row Source:

SELECT tbl_SysGroups.SysGroupID, tbl_SysGroups.SysGroupName FROM tbl_SysGroups ORDER BY tbl_SysGroups.SysGroupName

and Tag set to 2;(All)

Any idea why? Complete function is below for reference.

Function AddAllToList(C As Control, ID As Long, Row As Long, Col As Long, Code As Integer) As Variant

'***************************************************************

      ' FUNCTION: AddAllToList()

      '

      ' PURPOSE:

      '   Adds "(all)" as the first row of a combo box or list box.

      '

      ' USAGE:

      '   1. Create a combo box or list box that displays the data you

      '      want.

      '

      '   2. Change the RowSourceType property from "Table/Query" to

      '      "AddAllToList."

      '

      '   3. Set the value of the combo box or list box's Tag property to

      '      the column number in which you want "(all)" to appear.

      '

      '   NOTE: Following the column number in the Tag property, you can

      '   enter a semicolon (;) and then any text you want to appear

      '   other than the default "all."

      '

      '         For example

      '

      '             Tag: 2;<None>

      '

      '         displays "<None>" in the second column of the list.

      '

      '***************************************************************

         Static DB As Database, RS As Recordset

         Static DISPLAYID As Long

         Static DISPLAYCOL As Integer

         Static DISPLAYTEXT As String

         Dim Semicolon As Integer
 

      'On Error GoTo Err_AddAllToList
 

         Select Case Code

            Case LB_INITIALIZE

               ' See if the function is already in use.

               If DISPLAYID <> 0 Then

                  MsgBox "AddAllToList is already in use by another Control! """

                  AddAllToList = False

                  Exit Function

               End If
 

               ' Parse the display column and display text from the Tag

               ' property.

               DISPLAYCOL = 1

               DISPLAYTEXT = "(All)"

               If Not IsNull(C.Tag) Then

                  Semicolon = InStr(C.Tag, ";")

                  If Semicolon = 0 Then

                     DISPLAYCOL = Val(C.Tag)

                  Else

                     DISPLAYCOL = Val(Left(C.Tag, Semicolon - 1))

                     DISPLAYTEXT = Mid(C.Tag, Semicolon + 1)

                  End If

               End If
 

               ' Open the recordset defined in the RowSource property.

               Set DB = DBEngine.Workspaces(0).Databases(0)

               Set RS = DB.OpenRecordset(C.RowSource, DB_OPEN_SNAPSHOT)
 

               ' Record and return the ID for this function.

               DISPLAYID = Timer

               AddAllToList = DISPLAYID
 

            Case LB_OPEN

               AddAllToList = DISPLAYID
 

            Case LB_GETROWCOUNT

               ' Return the number of rows in the recordset.

               RS.MoveLast

               AddAllToList = RS.RecordCount + 1
 

            Case LB_GETCOLUMNCOUNT

               ' Return the number of fields (columns) in the recordset.

               AddAllToList = RS.Fields.Count
 

            Case LB_GETCOLUMNWIDTH

               AddAllToList = -1
 

            Case LB_GETVALUE

               ' Are you requesting the first row?

               If Row = 0 Then

                  ' Should the column display "(All)"?

                  If Col = DISPLAYCOL - 1 Then

                     ' If so, return "(All)."

                     AddAllToList = DISPLAYTEXT

                  Else

                     ' Otherwise, return NULL.

                     AddAllToList = Null

                  End If

               Else

                  ' Grab the record and field for the specified row/column.

                  RS.MoveFirst

                  RS.Move Row - 1

                  AddAllToList = RS(Col)

               End If

            Case LB_END

               DISPLAYID = 0

               RS.Close

         End Select
 

Bye_AddAllToList:

         Exit Function
 

Err_AddAllToList:

Beep:          MsgBox Error$, 16, "AddAllToList"

         AddAllToList = False

         Resume Bye_AddAllToList

End Function
 

Function ChangeQDef(Q As String, strSQL As String)

On Error GoTo Err_ChangeQDef

'Changes the SQL of the query Q to strSQL

    Dim qd As QueryDef
 

    Set qd = CurrentDb.QueryDefs(Q)

    qd.SQL = strSQL
 

Exit_ChangeQDef:

    Exit Function
 

Err_ChangeQDef:

    MsgBox Err.Description

    Resume Exit_ChangeQDef

End Function
 

Function IsObjectOpen(strName As String, Optional intObjectType As Integer = acForm) As Boolean

    'intObjectType can be:

    ' acTable (0)

    ' acQuery (1)

    ' acForm (2)

    ' acReport (3)

    ' acMacro (4)

    ' acModule (5)

    

    'Returns True if strName is open, False otherwise

    On Error Resume Next

        IsObjectOpen = (SysCmd(SYSCMD_GETOBJECTSTATE, intObjectType, strName) <> 0)

    If Err <> 0 Then

        IsObjectOpen = False

    End If

End Function
 

Function GetRedYellowGreen(dDate As Date) As Integer

On Error GoTo Err_GetRedYellowGreen

    

    GetRedYellowGreen = IIf(Nz([dDate], #1/1/2100#) > Date + 14, 0, IIf([dDate] > Date, 1, 2))

    

Exit_GetRedYellowGreen:

    Exit Function
 

Err_GetRedYellowGreen:

    MsgBox "Module: Utilities, GetRedYellowGreen " & Err.Description

    Resume Exit_GetRedYellowGreen

End Function
 

Function GetNextECMNumber() As String

    Dim strSQL As String

    Dim rst As New ADODB.Recordset

    

    strSQL = "SELECT Max([ECMNumber]) AS MaxOfECMNumber " & _

             "FROM tbl_ECMs"

             

    rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockPessimistic

    rst.MoveFirst

    GetNextECMNumber = "HFF-ECM-" & Format(Right(rst!MaxOfECMNumber, 4) + 1, "0000")

    

    rst.Close

    Set rst = Nothing

End Function
 

Function GetNumberofRows(strSQL As String) As Double

    Dim rst As New ADODB.Recordset

    

    rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockPessimistic

    rst.MoveFirst

    If rst.EOF Then

        GetNumberofRows = 0

    Else

        GetNumberofRows = rst.RecordCount

    End If

    

    rst.Close

    Set rst = Nothing

End Function
 

Function FilterGeneric(strFilter As String) As String

On Error GoTo Err_FilterGeneric

    Dim frm As Form, ctl As Control

    Dim varItem As Variant

    Dim FilterString As String

    

    Set frm = Forms!frm_ECMs

    Set ctl = Forms!frm_ECMs(DLookup("[FilterFormControl]", "[tbl_Filters]", "[FilterName]= '" & strFilter & "'"))
 

    FilterString = ""

    'enumerate selected items and concatenate to strSQL

    For Each varItem In ctl.ItemsSelected

        If ctl.ItemData(varItem) = 0 Then

            FilterGeneric = ""

            Exit Function

        Else

            FilterString = FilterString & " " & DLookup("[FilterSQLWHEREClause]", "[tbl_Filters]", "[FilterName]= '" & strFilter & "'") & "= " & ctl.ItemData(varItem) & " OR "

        End If

    Next varItem

    If Nz(FilterString, "") = "" Then

        FilterGeneric = ""

        Exit Function

    End If

    'Trim the end of strSQL

    FilterString = Left$(FilterString, InStrRev(FilterString, "OR") - 2)

    FilterGeneric = FilterString

    

Exit_FilterGeneric:

    Exit Function
 

Err_FilterGeneric:

    MsgBox Err.Description

    Resume Exit_FilterGeneric

End Function

Open in new window

0
Comment
Question by:Michael Vasilevsky
  • 2
3 Comments
 
LVL 28

Accepted Solution

by:
TextReport earned 500 total points
Comment Utility
In the code that contains the line with the error

Set RS = DB.OpenRecordset(C.RowSource, DB_OPEN_SNAPSHOT)

Endure the DIM for the RS variable is set to

DIM rs As DAO.Recordset

Also ensure you have a reference to the Microsoft DAO Library (probably versions 3.6). Go to VBA module, Tools Menu, References.

Cheers, Andrew
0
 
LVL 28

Expert Comment

by:TextReport
Comment Utility
Just seen it on line 29
Cheers, Andrew

         Static DB As DAO.Database, RS As DAO.Recordset
0
 
LVL 10

Author Comment

by:Michael Vasilevsky
Comment Utility
That's it thanks! I had the library referenced, but needed to add DAO. in my declarations.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

When you are entering numbers in a speadsheet, and don't remember what 6×7 is, you just type “=6*7" instead. It works in every cell! This is not so in Access. To enter the elusive 42 in a text box, you have to find a calculator, and then copy the re…
It took me quite some time to sort out all the different properties of combo and list boxes available from Visual Basic at run-time. Not that the documentation is lacking: the help pages are quite thorough and well written. The problem was rather wh…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now