Updating query on sub form

[rjchristensen]

I have a form with some date fields and listboxes. It has a subform that is tied to a query. The query pulls data from an external database (Progress) via ODBC. I am trying to use the reults of the entries in the date fields and listboxes to build a filter statement to further filter the associated starting query. As I walked through the code via the debugger and monitored the values, all seemed well. But when I try to update the query, the subform displays an empty view (no records). The value in the debugger says there are ~1500 records. If I try to run the query a second time, it doesn't even try to do it. Can I have the query as record source on the subform or should it be unbound?
What am I missing? (Beyond brain cells that is)

[MMcCarthy]

I'll need to see the code you are using to apply the filter.

[rjchristensen]

Part 1 of 2 of reply


This is the code for the fromDispatchBoard form:

Option Compare Database
 
Option Explicit
Private Const WS_CAPTION = &HC00000
 
Private Sub cmdExit_Click()
  CloseActiveForm
End Sub
 
Private Sub cmdMapit_Click()
  MapSelectedOrders
End Sub
 
Private Sub cmdUpdate_Click()
  SelectOrders
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
  If Not DB_Exit Then
    DoEvents
    Cancel = True
  Else
    Application.Quit
  End If
End Sub
Private Sub cmdReset_Click()
  'Clear the criteria
  Me!txtStartDate = vbNullString
  Me!txtEndDate = vbNullString
  'Reset the selected properties
  ExecuteSQL "SELECT qryDispatchBoard.* FROM qryDispatchBoard ORDER BY qryDispatchBoard.[s-date];"
  'Clear the properties filter
  Me![subFrmSubDispatchBoard].Form.FilterOn = False
  Me![subFrmSubDispatchBoard].Form.Refresh
  Me!lstBoard = Nothing
  Me!lstTechnician = Nothing
  Me!lstCity = Nothing
  Me!lstZipcode = Nothing
  Me!lstMapCoord = Nothing
End Sub
Sub SelectOrders()
  'Displays Orders that match the criteria
  On Error GoTo SelectOrders_Err
  Dim strFilter As String
  Dim strSQL As String
  strSQL = vbNullString
  strFilter = vbNullString
  'Get the WHERE clause that defines the filter
  strFilter = OrderFilter()
  If strFilter <> vbNullString Then
    'Apply the filter
    strSQL = "SELECT qryDispatchBoard.* FROM qryDispatchBoard WHERE " & strFilter & ";"
    If NumRecords(strSQL) > 0 Then
      Me![subFrmSubDispatchBoard].Form.Filter = strFilter
      Me![subFrmSubDispatchBoard].Form.FilterOn = True
      ExecuteSQL strSQL
    Else
      MsgBox "No records match input criteria.", vbOKOnly, APP_NAME
    End If
  Else
    Me![subFrmSubDispatchBoard].Form.FilterOn = False
  End If
SelectOrders_Err_Exit:
  Exit Sub
SelectOrders_Err:
  Resume SelectOrders_Err_Exit
End Sub
Private Function OrderFilter() As String
  'Create the WHERE clause that will be used as a filter
  Dim intNoCriteria As Integer
  Dim substrSQL As String
  Dim BoardList As String
  Dim lstBoard As ListBox
  Dim lstTechnician As ListBox
  Dim lstCity As ListBox
  Dim lstZip As ListBox
  Dim lstMapCoord As ListBox
  Dim TechnicianList As String
  Dim CityList As String
  Dim ZipList As String
  Dim MapCoordList As String
  BoardList = vbNullString
  TechnicianList = vbNullString
  CityList = vbNullString
  ZipList = vbNullString
  MapCoordList = vbNullString
  substrSQL = vbNullString
  OrderFilter = vbNullString
  intNoCriteria = False
  intNoCriteria = IsNothing(Me!txtStartDate)
  intNoCriteria = intNoCriteria And IsNothing(Me!txtEndDate)
  If Not intNoCriteria Then
    If Not IsNothing(Me!txtStartDate) And Not IsNothing(Me!txtEndDate) Then
      substrSQL = "qryDispatchBoard.[s-date] between #" & Me!txtStartDate & "# AND #" & Me!txtEndDate & "#"
    End If
  End If
  If Me!lstBoard.ItemsSelected.Count > 0 Then
    If Left(substrSQL, 1) <> "(" Then
      substrSQL = "(" & substrSQL & ")"
    End If
    BoardList = ListBoxContents(Me!lstBoard)
    If numFound = 1 Then
        substrSQL = substrSQL & "AND qryDispatchBoard.[s-type-call] = " & BoardList
    Else
        substrSQL = substrSQL & "AND (qryDispatchBoard.[s-type-call] = " & BoardList & ")"
    End If
  End If
  If Me!lstTechnician.ItemsSelected.Count > 0 Then
    If Left(substrSQL, 1) <> "(" Then
      substrSQL = "(" & substrSQL & ")"
    End If
    TechnicianList = ListBoxContents(Me!lstTechnician)
    If numFound = 1 Then
        substrSQL = substrSQL & " AND qryDispatchBoard.[emp-id] = " & TechnicianList
    Else
        substrSQL = substrSQL & " AND (qryDispatchBoard.[emp-id] = " & TechnicianList & ")"
    End If
  End If
  If Me!lstCity.ItemsSelected.Count > 0 Then
    If Left(substrSQL, 1) <> "(" Then
      substrSQL = "(" & substrSQL & ")"
    End If
    CityList = ListBoxContents(Me!lstCity)
    If numFound = 1 Then
        substrSQL = substrSQL & " AND qryDispatchBoard.city = " & CityList
    Else
        substrSQL = substrSQL & " AND (qryDispatchBoard.city = " & CityList & ")"
    End If
  End If
  If Me!lstZip.ItemsSelected.Count > 0 Then
    If Left(substrSQL, 1) <> "(" Then
      substrSQL = "(" & substrSQL & ")"
    End If
    ZipList = ListBoxContents(Me!lstZip)
    If numFound = 1 Then
        substrSQL = substrSQL & " AND qryDispatchBoard.zip = " & ZipList
    Else
        substrSQL = substrSQL & " AND (qryDispatchBoard.zip = " & ZipList & ")"
    End If
  End If
  If Me!lstMapCoord.ItemsSelected.Count > 0 Then
    If Left(substrSQL, 1) <> "(" Then
      substrSQL = "(" & substrSQL & ")"
    End If
    MapCoordList = ListBoxContents(Me!lstMapCoord)
    If numFound = 1 Then
        substrSQL = substrSQL & " AND qryDispatchBoard.[map-coor] = " & MapCoordList
    Else
        substrSQL = substrSQL & " AND (qryDispatchBoard.[map-coor] = " & MapCoordList & ")"
    End If
  End If
  OrderFilter = Trim(substrSQL)
End Function
Sub MapSelectedOrders()
  'Map the selected properties
  On Error GoTo MapSelectedProperties_Err_Exit
  Dim db As Database
  Dim rstProps As Recordset
 
  Dim objLoc As MapPoint.Location
  Dim objMap As MapPoint.Map
  Dim objPushpin As MapPoint.Pushpin
 
  Dim strMsg As String
  Dim i As Integer
  i = 0
  Set db = CurrentDb()
 
  'Load the selected properties into a recordset
  Set rstProps = db.OpenRecordset("SELECT * FROM tblProperties WHERE ysnSelected = Yes;")
  'Make sure at least one property was selected
  If rstProps.RecordCount > 0 Then
    'Load Map
    If LoadMap() Then
      'Open the form containing the map
      FormOpen "frmMap"
      Set objMap = gappMP.ActiveMap
      'Place a pushpin on the map for each selected property
      While Not rstProps.EOF
        i = i + 1
        Set objLoc = objMap.FindAddressResults(rstProps!strStreet, rstProps!strCity, rstProps!strState, rstProps!strPostalCode)(1)
        Set objPushpin = objMap.AddPushpin(objLoc, rstProps!strStreet)
        objPushpin.name = CStr(i)
        objPushpin.Note = "$" & rstProps!curListPrice
        objPushpin.BalloonState = geoDisplayBalloon
        objPushpin.Symbol = 77
        objPushpin.Highlight = True
        rstProps.MoveNext
      Wend
      'Show all pushpins on the map display
      objMap.DataSets.ZoomTo
    Else
      strMsg = "Unable to load map."
      MsgBox strMsg, vbOKOnly + vbExclamation, APP_NAME
    End If
  Else
    strMsg = "No properties selected."
    MsgBox strMsg, vbOKOnly + vbExclamation, APP_NAME
  End If
MapSelectedProperties_Err_Exit:
  On Error Resume Next
  Set objPushpin = Nothing
  Set objLoc = Nothing
  Set objMap = Nothing
  rstProps.Close
  db.Close
  Exit Sub
MapSelectedProperties_Err:
  Resume MapSelectedProperties_Err_Exit
End Sub
Function LoadMap() As Boolean
  'Create an instance of MapPoint
  On Error GoTo LoadMap_Err
  Set gappMP = CreateObject("MapPoint.Application")
  gappMP.Visible = False
  gappMP.PaneState = geoPaneNone
  'Get the handle of the MapPoint Window
  ghwndMP = FindWindow(vbNullString, "Map - Microsoft MapPoint North America")
  'Remove MapPoint Title Bar
  FlipBit ghwndMP, WS_CAPTION, False
  LoadMap = True
LoadMap_Err_Exit:
  Exit Function
LoadMap_Err:
  LoadMap = False
  GoTo LoadMap_Err_Exit
End Function

[rjchristensen]

Part 2 of 2 of reply

This is the module for all the public functions and subs:

Option Compare Database
 
Option Explicit
 
Global Const APP_NAME = "Dispatch Board Mapper"
 
'Reference to MapPoint
Public gappMP As MapPoint.Application
 
'Handle to MapPoint Window
Public ghwndMP As Long
 
'Used to get window style bits.
Public Const GWL_EXSTYLE = -20
Public Const GWL_STYLE = -16
 
'Force total redraw that shows new styles.
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOSIZE = &H1
 
Public numFound As Integer
 
'********************************************************
'* Window's API Function Prototypes
'********************************************************
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
       (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Public Declare Function SetParent Lib "user32" _
       (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
       (ByVal hwnd As Long, ByVal nIndex As Long) As Long
 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
       (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
Public Declare Function SetWindowPos Lib "user32" _
       (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Public Declare Function GetWindowThreadProcessId Lib "user32.dll" _
       (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Function DB_Startup()
  On Error Resume Next
  FormOpen "frmDispatchBoard"
End Function
Public Function DB_Exit() As Boolean
  On Error Resume Next
  Dim strMsg As String
  DB_Exit = False
  strMsg = "Exit " & APP_NAME & "?"
  If MsgBox(strMsg, vbExclamation + vbYesNo + vbDefaultButton1, APP_NAME & " Exit") = vbYes Then
    If IsFormOpen("frmDispatchMap") Then
      gappMP.ActiveMap.Saved = True
      gappMP.Quit
      CloseForm "frmDispatchMap"
    End If
    DB_Exit = True
    CloseForm "frmDispatchBoard"
  End If
End Function
Public Sub FlipBit(hwnd As Long, ByVal lngStyleBit As Long, ByVal bValue As Boolean)
  'Windows Style Manipulation Function
  Dim lngStyle As Long
  'Retrieve current style bits
  lngStyle = GetWindowLong(hwnd, GWL_STYLE)
  'Set requested bit On or Off
  If bValue Then
    lngStyle = lngStyle Or lngStyleBit
  Else
    lngStyle = lngStyle And Not lngStyleBit
  End If
  SetWindowLong hwnd, GWL_STYLE, lngStyle
  'Redraw the window
  Redraw hwnd
End Sub
Public Sub Redraw(hwnd As Long)
  'Redraw window with new style
  Const swpFlags As Long = SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE
  SetWindowPos hwnd, 0, 0, 0, 0, 0, swpFlags
End Sub
Public Sub CloseForm(strForm As String)
  On Error Resume Next
  DoCmd.Close A_FORM, strForm
End Sub
Public Function IsNothing(v As Variant) As Integer
  'Returns TRUE if the value passed in is Empty, Null, or a zero
  'length string, or if a string is blank.
  IsNothing = False
  Select Case VarType(v)
    Case V_EMPTY
      IsNothing = True
    Case V_NULL
      IsNothing = True
    Case V_STRING
      If Len(v) = 0 Or v = " " Then
        IsNothing = True
      End If
    Case Else
      IsNothing = False
    End Select
End Function
Public Function ListBoxContents(LB As ListBox) As String
    'Returns extended SQL code if selected entries are found
    'Null if none are selected
    Dim intCurrentRow As Integer
    ListBoxContents = vbNullString
    numFound = 0
    For intCurrentRow = 0 To LB.ColumnCount - 1
        If LB(intCurrentRow) Then
            numFound = numFound + 1
            If numFound > 1 Then
                ListBoxContents = ListBoxContents & " OR " & LB.Column(intCurrentRow)
            Else
                ListBoxContents = LB.Column(intCurrentRow)
            End If
        End If
    Next intCurrentRow
End Function
Public Sub CloseActiveForm()
  On Error Resume Next
  DoCmd.Close A_FORM, Screen.ActiveForm.FormName
End Sub
Public Function NumRecords(strSQL As String) As Long
  On Error Resume Next
  Dim db As Database
  Dim rstTmp As Recordset
  Set db = CurrentDb()
  Set rstTmp = db.OpenRecordset(strSQL)
  rstTmp.MoveLast
  NumRecords = rstTmp.RecordCount
  rstTmp.Close
  db.Close
End Function
Public Sub ExecuteSQL(strSQL As String)
  On Error Resume Next
  Dim db As Database
  Set db = CurrentDb()
  db.Execute strSQL, dbSeeChanges
  db.Close
End Sub
Public Sub FormOpen(strFormName As String)
  On Error Resume Next
  DoCmd.OpenForm strFormName, A_NORMAL
End Sub
Public Function IsFormOpen(strFormName As String)
  On Error Resume Next
  IsFormOpen = (SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0)
End Function
Public Function GetAppPath() As String
  'Returns the path and name of the currently executing library database
  Dim db As Database
  Set db = CodeDb()
  GetAppPath = db.name
  db.Close
End Function
Public Function GetAppDir() As String
  'Returns the directory of the local DB
  GetAppDir = GetDirPart(GetAppPath())
End Function
Public Function GetDirPart(strIn As String) As String
  'Returns the directory fully qualified file name
  Dim intCounter As Integer
  Dim strTmp As String
  For intCounter = Len(strIn) To 1 Step -1
    If Mid$(strIn, intCounter, 1) <> "\" Then
      strTmp = Mid$(strIn, intCounter, 1) & strTmp
    Else
      Exit For
    End If
  Next intCounter
  GetDirPart = Mid(strIn, 1, Len(strIn) - Len(strTmp))
End Function
Function CopyFile(strSource As String, strDest As String) As Boolean
  'Copy a the source file to the destination
  On Error GoTo CopyFile_Err
  Dim fs As Object
  Set fs = CreateObject("Scripting.FileSystemObject")
  fs.CopyFile strSource, strDest
  Set fs = Nothing
  CopyFile = True
CopyFile_Err_Exit:
  Exit Function
CopyFile_Err:
  CopyFile = False
  Resume CopyFile_Err_Exit
End Function

[MMcCarthy]

Sub SelectOrders()
  'Displays Orders that match the criteria
  On Error GoTo SelectOrders_Err
  Dim strFilter As String
  Dim strSQL As String
  strSQL = vbNullString
  strFilter = vbNullString
  'Get the WHERE clause that defines the filter
  strFilter = OrderFilter()
  If strFilter <> vbNullString Then
    'Apply the filter
    strSQL = "SELECT qryDispatchBoard.* FROM qryDispatchBoard WHERE " & strFilter & ";"
    If NumRecords(strSQL) > 0 Then
      Me![subFrmSubDispatchBoard].Form.Filter = strFilter
      Me![subFrmSubDispatchBoard].Form.FilterOn = True
      ExecuteSQL strSQL
    Else
      MsgBox "No records match input criteria.", vbOKOnly, APP_NAME
    End If
  Else
    Me![subFrmSubDispatchBoard].Form.FilterOn = False
  End If
    Me![subFrmSubDispatchBoard].Form.Requery
SelectOrders_Err_Exit:
  Exit Sub
SelectOrders_Err:
  Resume SelectOrders_Err_Exit
End Sub
 

Try requerying the subform as above