P
pic078 via AccessMonster.com
Hi All, I have posted this issue a few times with no success - still hoping
someone out there can help me - I'm using Access 2002 with front-end/back-end.
Application runs fine. No error messages. However, access remains stuck in
memory whenever the code below is run repetitively (three times or more)
prior to quitting application - these procedures are tied to a search button,
the results from which are spit out into excel. Only way to reopen database
is by manually removing MSACCESS.EXE process from task manager. The process
only hangs when this code is run several times in a short period of time.
Don't know what's causing it, but seems to be contained to the three
functions below (the first builds the SQL string - I think the issue may be
within the latter two:
Option Compare Database
Option Explicit
Public strFullString As String
Public lngRecordsAffected As Long
Public strWineType As String
Public strVarietal As String
Public strVintage As String
Public strWineStyle As String
Public strReserve As String
Public strUnfiltered As String
Public strUnoaked As String
Public strStartDate As String
Public strEndDate As String
Public strMinPrice As String
Public strMaxPrice As String
Public strMinRating As String
Public strMaxRating As String
Public strCountry As String
Public strState As String
Public strRegion As String
Public strAppellation As String
Function BuildSearchString() As Boolean
On Error GoTo Err_BuildSearchString
'Declarations
Dim frm As Form
Dim strFrom As String
Dim strWhere As String
Dim strBuildString As String
Dim strBuildCriteria As String
Dim strDelim As String
Dim strChk As String
Dim boofirstflag As Boolean
Dim intSelItem As Variant
'Start building search string
'Set the SELECT statement
Const strSelect = "SELECT tblWineNotes.BottleID "
'Set the FROM statement based on which listboxes are used
'Choosing Country, State, Region or Appellation creates a right join with
tblWineMap table
'Const strFrom = "FROM tblGames " (this is no longer being used)
With Forms("frmReportsMain")
'Check to see if any of the geographical listboxes are being used
If .lboCountry.ItemsSelected.Count _
Or .lboState.ItemsSelected.Count _
Or .lboRegion.ItemsSelected.Count _
Or .lboAppellation.ItemsSelected.Count Then
strFrom = "FROM tblWineMap RIGHT JOIN tblWineNotes ON tblWineMap.
RegionID=tblWineNotes.RegionID "
Else
strFrom = "FROM tblWineNotes "
End If
End With
'Set the ORDER BY statement
Const strOrderBy = "ORDER BY tblWineNotes.TastingDate DESC;"
'Set the strDelim string
strDelim = """"
'Building the string now that we have strSelect and strFrom
strFullString = strSelect & strFrom
boofirstflag = False ' this flag shows whether a WHERE has yet been
added
Set frm = Forms("frmReportsMain")
' Search by WineType
If frm.lboWineType.ItemsSelected.Count Then
boofirstflag = True
strWhere = "WHERE tblWineNotes.WineTypeID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboWineType.ItemsSelected
strBuildString = strBuildString & "," & frm.lboWineType.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboWineType.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strWineType = "Wine Type: " & strBuildCriteria
Else
strWineType = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Varietal
If frm.lboVarietal.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.PrimaryGrapeID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboVarietal.ItemsSelected
strBuildString = strBuildString & "," & frm.lboVarietal.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboVarietal.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strVarietal = "Primary Varietal: " & strBuildCriteria
Else
strVarietal = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Vintage
If frm.lboVintage.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.VintageID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboVintage.ItemsSelected
strBuildString = strBuildString & "," & frm.lboVintage.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboVintage.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strVintage = "Vintage: " & strBuildCriteria
Else
strVintage = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by WineStyle
If frm.lboWineStyle.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.WineStyle In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboWineStyle.ItemsSelected
strBuildString = strBuildString & "," & strDelim & frm.
lboWineStyle.ItemData(intSelItem) & strDelim
strBuildCriteria = strBuildCriteria & ", " & frm.lboWineStyle.
Column(0, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strWineStyle = "Wine Style: " & strBuildCriteria
Else
strWineStyle = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Reserve
If frm.chkReserve.Value = -1 Or frm.chkReserve.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Reserve = " & frm.chkReserve.
Value & " "
Select Case frm.chkReserve
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strReserve = "Reserve: " & strChk
Else
strReserve = ""
End If
' Search by Unfiltered
If frm.chkUnfiltered.Value = -1 Or frm.chkUnfiltered.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Unfiltered = " & frm.
chkUnfiltered.Value & " "
Select Case frm.chkUnfiltered
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strUnfiltered = "Unfiltered: " & strChk
Else
strUnfiltered = ""
End If
' Search by Unoaked
If frm.chkUnoaked.Value = -1 Or frm.chkUnoaked.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Unoaked = " & frm.chkUnoaked.
Value & " "
Select Case frm.chkUnoaked
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strUnoaked = "Unoaked: " & strChk
Else
strUnoaked = ""
End If
' Search by Start Date
If Not IsNull([frm].[txtStartDate]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.TastingDate >= " & "#" & Format((
[frm].[txtStartDate]), "mm/dd/yyyy") & "# "
strStartDate = "Start Date: " & Format(([frm].[txtStartDate]),
"mm/dd/yyyy")
Else
strStartDate = ""
End If
' Search End Date
If Not IsNull([frm].[txtEndDate]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.TastingDate <= " & "#" & Format((
[frm].[txtEndDate]), "mm/dd/yyyy") & "# "
strEndDate = "End Date: " & Format(([frm].[txtEndDate]), "mm/dd/yyyy")
Else
strEndDate = ""
End If
' Search by Min Price
If Not IsNull([frm].[txtMinPrice]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Price >= " & ([frm].[txtMinPrice])
& " "
strMinPrice = "Min Price: " & Format(([frm].[txtMinPrice]), "$#,##0.
00")
Else
strMinPrice = ""
End If
' Search by Max Price
If Not IsNull([frm].[txtMaxPrice]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Price <= " & ([frm].[txtMaxPrice])
& " "
strMaxPrice = "Max Price: " & Format(([frm].[txtMaxPrice]), "$#,##0.
00")
Else
strMaxPrice = ""
End If
' Search by Min Rating
If Not IsNull([frm].[txtMinRating]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.ScaleRating >= " & ([frm].
[txtMinRating]) & " "
strMinRating = "Min Rating: " & Format(([frm].[txtMinRating]), "0.00")
Else
strMinRating = ""
End If
' Search by Max Rating
If Not IsNull([frm].[txtMaxRating]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.ScaleRating <= " & ([frm].
[txtMaxRating]) & " "
strMaxRating = "Max Rating: " & Format(([frm].[txtMaxRating]), "0.00")
Else
strMaxRating = ""
End If
' Search by Country
If frm.lboCountry.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.Country In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboCountry.ItemsSelected
strBuildString = strBuildString & "," & frm.lboCountry.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboCountry.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strCountry = "Country: " & strBuildCriteria
Else
strCountry = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by State
If frm.lboState.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.State In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboState.ItemsSelected
strBuildString = strBuildString & "," & frm.lboState.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboState.Column
(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strState = "State: " & strBuildCriteria
Else
strState = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Region
If frm.lboRegion.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.Region In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboRegion.ItemsSelected
strBuildString = strBuildString & "," & frm.lboRegion.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboRegion.Column
(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strRegion = "Region: " & strBuildCriteria
Else
strRegion = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Appellation
If frm.lboAppellation.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
End If
strWhere = strWhere & "tblWineMap.Appellation In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboAppellation.ItemsSelected
strBuildString = strBuildString & "," & frm.lboAppellation.
ItemData(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboAppellation.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strAppellation = "Appellation: " & strBuildCriteria
Else
strAppellation = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
'Search string components have been built
'So let's put them all together now...
strFullString = strFullString & strWhere & strOrderBy
Set intSelItem = Nothing
strChk = ""
strDelim = ""
strWhere = ""
strFrom = ""
Set frm = Nothing
BuildSearchString = True
Exit_BuildSearchString:
Exit Function
Err_BuildSearchString:
MsgBox Err.Description
Resume Exit_BuildSearchString
End Function
Function BuildResultsTable(strFullString As String) As Boolean
Dim db As DAO.Database
Dim qdfAppend As DAO.QueryDef
Dim qdfTruncate As DAO.QueryDef
Dim strTruncate As String
Set db = CurrentDb()
'Delete previous search results before appending new search results to
tblSearchResults table
strTruncate = "DELETE zstblSearchResults.* FROM zstblSearchResults;"
On Error Resume Next
Set qdfTruncate = db.CreateQueryDef("", strTruncate)
qdfTruncate.Execute dbFailOnError
qdfTruncate.Close
On Error GoTo 0
'Append new search results
strFullString = "INSERT INTO zstblSearchResults " & strFullString
Set qdfAppend = db.CreateQueryDef("", strFullString)
qdfAppend.Execute dbFailOnError
lngRecordsAffected = qdfAppend.RecordsAffected
qdfAppend.Close
Set qdfTruncate = Nothing
Set qdfAppend = Nothing
Set db = Nothing
BuildResultsTable = True
End Function
Function DisplayResults(lngRecordsAffected As Long) As Boolean
'Declarations
Dim frm As Form
Dim intReturn As Integer
Dim strMsg As String
Dim strRpt As String
Dim strQueryName As String
Dim strSheetName As String
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlSheet2 As Excel.Worksheet
Dim xlRange As Excel.Range
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim critVar As Variant
Dim CriteriaGroup(1 To 17) As String
Set frm = Forms("frmReportsMain")
Select Case lngRecordsAffected
Case 0
strMsg = "No wines matched the criteria you specified."
MsgBox strMsg, vbExclamation, Application.Name
DisplayResults = True
Exit Function
Case 1
strMsg = "Your search returned 1 wine."
strMsg = strMsg & vbCrLf & vbCrLf & "Would you like to proceed?"
Case Is > 1
strMsg = "Your search returned " & lngRecordsAffected & " wines."
strMsg = strMsg & vbCrLf & vbCrLf & "Would you like to proceed?"
End Select
intReturn = MsgBox(strMsg, _
vbQuestion + vbYesNo + vbDefaultButton1, _
Application.Name)
If intReturn = vbYes Then
'Declare string parameters to insert into reusable procedure...
Select Case frm.cboReportType
Case 1
strRpt = ""
strQueryName = "qryWinesAtAGlanceRpt"
strSheetName = "Wines at a Glance"
Case 2
strRpt = ""
strQueryName = "qryWineListRpt"
strSheetName = "Wine List"
Case 3
strRpt = ""
strQueryName = "qryBlendRpt"
strSheetName = "Blend Report"
Case 4
strRpt = ""
strQueryName = "qryProducerListRpt"
strSheetName = "Producer List"
End Select
'Run report depending on format selecttion...
Select Case frm.cboFormatType
Case 1
'DoCmd.OpenForm strRpt, acNormal
Case 2
DoCmd.Hourglass True
CriteriaGroup(1) = strWineType
CriteriaGroup(2) = strVarietal
CriteriaGroup(3) = strVintage
CriteriaGroup(4) = strWineStyle
CriteriaGroup(5) = strReserve
CriteriaGroup(6) = strUnfiltered
CriteriaGroup(7) = strUnoaked
CriteriaGroup(8) = strStartDate
CriteriaGroup(9) = strEndDate
CriteriaGroup(10) = strMinPrice
CriteriaGroup(11) = strMaxPrice
CriteriaGroup(12) = strMinRating
CriteriaGroup(13) = strMaxRating
CriteriaGroup(14) = strCountry
CriteriaGroup(15) = strState
CriteriaGroup(16) = strRegion
CriteriaGroup(17) = strAppellation
'First, we need to build criteria strings and insert them into Excel
'Set xlApp = CreateObject("Excel.Application")
Set xlApp = New Excel.Application
Set xlWorkbook = xlApp.Workbooks.Add
Set xlSheet = xlWorkbook.Worksheets.Add
With xlSheet.Cells(1, 1)
.Value = "Search Criteria Selected:"
.Font.Bold = True
End With
x = 3
For Each critVar In CriteriaGroup
If critVar <> "" Then
With xlSheet
.Cells(x, 1).Value = critVar
End With
x = x + 1
End If
Next critVar
xlSheet.Columns.AutoFit
xlSheet.Name = "Search Criteria"
'Now that we have criteria built into worksheet,
'we need to export the actual data that matched criteria
'BEGINNING OF ORIGINAL CODE...
Set db = CurrentDb()
Set rst = db.OpenRecordset(strQueryName)
Set xlSheet2 = xlWorkbook.Worksheets.Add
'Set xlSheet = xlWorkbook.Sheets.Add
'Set xlSheet = xlWorkbook.Sheets.(1)
y = 1
For Each fld In rst.Fields
With xlSheet2
.Cells(1, y).Value = fld.Name
.Cells(1, y).Font.Bold = True
End With
y = y + 1
Next fld
Set xlRange = xlSheet2.Cells(2, 1)
xlRange.CopyFromRecordset rst
xlSheet2.Name = strSheetName 'Or just create a straight forward name
surrounded by double quotes like a string
xlSheet2.Columns.AutoFit
rst.Close
'Run some customized formatting depending on report type...
Select Case frm.cboReportType
Case 1
Set xlRange = xlSheet2.Columns("T:T")
xlRange.NumberFormat = "$#,##0.00"
Set xlRange = xlSheet2.Columns("AD:AD")
xlRange.NumberFormat = "0.0%"
Set xlRange = xlSheet2.Columns("AF:AF")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AJ:AJ")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AK:AK")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AL:AL")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AM:AM")
xlRange.NumberFormat = "0.0"
Case 2
Set xlRange = xlSheet2.Columns("E:E")
xlRange.NumberFormat = "$#,##0.00"
Set xlRange = xlSheet2.Columns("F:F")
xlRange.NumberFormat = "0.00"
Case 3
Case 4
Set xlRange = xlSheet2.Columns("C
")
xlRange.NumberFormat = "[<=9999999]###-####;(###) ###-####"
End Select
xlApp.Visible = True
DoCmd.Hourglass False
End Select
End If
'Previous code for clearing out hanging criteria strings was located here...
'Run clear procedure again to clear up some memory...
Call ClearSearchStrings
strQueryName = ""
strSheetName = ""
Set frm = Nothing
Set critVar = Nothing
Erase CriteriaGroup()
Set fld = Nothing
Set rst = Nothing
Set db = Nothing
Set xlRange = Nothing
Set xlSheet2 = Nothing
Set xlSheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing
DisplayResults = True
End Function
someone out there can help me - I'm using Access 2002 with front-end/back-end.
Application runs fine. No error messages. However, access remains stuck in
memory whenever the code below is run repetitively (three times or more)
prior to quitting application - these procedures are tied to a search button,
the results from which are spit out into excel. Only way to reopen database
is by manually removing MSACCESS.EXE process from task manager. The process
only hangs when this code is run several times in a short period of time.
Don't know what's causing it, but seems to be contained to the three
functions below (the first builds the SQL string - I think the issue may be
within the latter two:
Option Compare Database
Option Explicit
Public strFullString As String
Public lngRecordsAffected As Long
Public strWineType As String
Public strVarietal As String
Public strVintage As String
Public strWineStyle As String
Public strReserve As String
Public strUnfiltered As String
Public strUnoaked As String
Public strStartDate As String
Public strEndDate As String
Public strMinPrice As String
Public strMaxPrice As String
Public strMinRating As String
Public strMaxRating As String
Public strCountry As String
Public strState As String
Public strRegion As String
Public strAppellation As String
Function BuildSearchString() As Boolean
On Error GoTo Err_BuildSearchString
'Declarations
Dim frm As Form
Dim strFrom As String
Dim strWhere As String
Dim strBuildString As String
Dim strBuildCriteria As String
Dim strDelim As String
Dim strChk As String
Dim boofirstflag As Boolean
Dim intSelItem As Variant
'Start building search string
'Set the SELECT statement
Const strSelect = "SELECT tblWineNotes.BottleID "
'Set the FROM statement based on which listboxes are used
'Choosing Country, State, Region or Appellation creates a right join with
tblWineMap table
'Const strFrom = "FROM tblGames " (this is no longer being used)
With Forms("frmReportsMain")
'Check to see if any of the geographical listboxes are being used
If .lboCountry.ItemsSelected.Count _
Or .lboState.ItemsSelected.Count _
Or .lboRegion.ItemsSelected.Count _
Or .lboAppellation.ItemsSelected.Count Then
strFrom = "FROM tblWineMap RIGHT JOIN tblWineNotes ON tblWineMap.
RegionID=tblWineNotes.RegionID "
Else
strFrom = "FROM tblWineNotes "
End If
End With
'Set the ORDER BY statement
Const strOrderBy = "ORDER BY tblWineNotes.TastingDate DESC;"
'Set the strDelim string
strDelim = """"
'Building the string now that we have strSelect and strFrom
strFullString = strSelect & strFrom
boofirstflag = False ' this flag shows whether a WHERE has yet been
added
Set frm = Forms("frmReportsMain")
' Search by WineType
If frm.lboWineType.ItemsSelected.Count Then
boofirstflag = True
strWhere = "WHERE tblWineNotes.WineTypeID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboWineType.ItemsSelected
strBuildString = strBuildString & "," & frm.lboWineType.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboWineType.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strWineType = "Wine Type: " & strBuildCriteria
Else
strWineType = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Varietal
If frm.lboVarietal.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.PrimaryGrapeID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboVarietal.ItemsSelected
strBuildString = strBuildString & "," & frm.lboVarietal.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboVarietal.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strVarietal = "Primary Varietal: " & strBuildCriteria
Else
strVarietal = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Vintage
If frm.lboVintage.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.VintageID In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboVintage.ItemsSelected
strBuildString = strBuildString & "," & frm.lboVintage.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboVintage.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strVintage = "Vintage: " & strBuildCriteria
Else
strVintage = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by WineStyle
If frm.lboWineStyle.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.WineStyle In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboWineStyle.ItemsSelected
strBuildString = strBuildString & "," & strDelim & frm.
lboWineStyle.ItemData(intSelItem) & strDelim
strBuildCriteria = strBuildCriteria & ", " & frm.lboWineStyle.
Column(0, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strWineStyle = "Wine Style: " & strBuildCriteria
Else
strWineStyle = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Reserve
If frm.chkReserve.Value = -1 Or frm.chkReserve.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Reserve = " & frm.chkReserve.
Value & " "
Select Case frm.chkReserve
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strReserve = "Reserve: " & strChk
Else
strReserve = ""
End If
' Search by Unfiltered
If frm.chkUnfiltered.Value = -1 Or frm.chkUnfiltered.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Unfiltered = " & frm.
chkUnfiltered.Value & " "
Select Case frm.chkUnfiltered
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strUnfiltered = "Unfiltered: " & strChk
Else
strUnfiltered = ""
End If
' Search by Unoaked
If frm.chkUnoaked.Value = -1 Or frm.chkUnoaked.Value = 0 Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Unoaked = " & frm.chkUnoaked.
Value & " "
Select Case frm.chkUnoaked
Case -1
strChk = "TRUE"
Case 0
strChk = "FALSE"
End Select
strUnoaked = "Unoaked: " & strChk
Else
strUnoaked = ""
End If
' Search by Start Date
If Not IsNull([frm].[txtStartDate]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.TastingDate >= " & "#" & Format((
[frm].[txtStartDate]), "mm/dd/yyyy") & "# "
strStartDate = "Start Date: " & Format(([frm].[txtStartDate]),
"mm/dd/yyyy")
Else
strStartDate = ""
End If
' Search End Date
If Not IsNull([frm].[txtEndDate]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.TastingDate <= " & "#" & Format((
[frm].[txtEndDate]), "mm/dd/yyyy") & "# "
strEndDate = "End Date: " & Format(([frm].[txtEndDate]), "mm/dd/yyyy")
Else
strEndDate = ""
End If
' Search by Min Price
If Not IsNull([frm].[txtMinPrice]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Price >= " & ([frm].[txtMinPrice])
& " "
strMinPrice = "Min Price: " & Format(([frm].[txtMinPrice]), "$#,##0.
00")
Else
strMinPrice = ""
End If
' Search by Max Price
If Not IsNull([frm].[txtMaxPrice]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.Price <= " & ([frm].[txtMaxPrice])
& " "
strMaxPrice = "Max Price: " & Format(([frm].[txtMaxPrice]), "$#,##0.
00")
Else
strMaxPrice = ""
End If
' Search by Min Rating
If Not IsNull([frm].[txtMinRating]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.ScaleRating >= " & ([frm].
[txtMinRating]) & " "
strMinRating = "Min Rating: " & Format(([frm].[txtMinRating]), "0.00")
Else
strMinRating = ""
End If
' Search by Max Rating
If Not IsNull([frm].[txtMaxRating]) Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineNotes.ScaleRating <= " & ([frm].
[txtMaxRating]) & " "
strMaxRating = "Max Rating: " & Format(([frm].[txtMaxRating]), "0.00")
Else
strMaxRating = ""
End If
' Search by Country
If frm.lboCountry.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.Country In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboCountry.ItemsSelected
strBuildString = strBuildString & "," & frm.lboCountry.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboCountry.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strCountry = "Country: " & strBuildCriteria
Else
strCountry = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by State
If frm.lboState.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.State In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboState.ItemsSelected
strBuildString = strBuildString & "," & frm.lboState.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboState.Column
(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strState = "State: " & strBuildCriteria
Else
strState = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Region
If frm.lboRegion.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
boofirstflag = True
End If
strWhere = strWhere & "tblWineMap.Region In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboRegion.ItemsSelected
strBuildString = strBuildString & "," & frm.lboRegion.ItemData
(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboRegion.Column
(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strRegion = "Region: " & strBuildCriteria
Else
strRegion = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
' Search by Appellation
If frm.lboAppellation.ItemsSelected.Count Then
If boofirstflag = True Then
strWhere = strWhere & "AND "
Else
strWhere = "WHERE "
End If
strWhere = strWhere & "tblWineMap.Appellation In ("
strBuildString = ""
strBuildCriteria = ""
For Each intSelItem In frm.lboAppellation.ItemsSelected
strBuildString = strBuildString & "," & frm.lboAppellation.
ItemData(intSelItem)
strBuildCriteria = strBuildCriteria & ", " & frm.lboAppellation.
Column(1, intSelItem)
Next intSelItem
If strBuildString <> "" Then
strBuildString = Right(strBuildString, Len(strBuildString) - 1)
End If 'strips out superfluous leading comma
If strBuildCriteria <> "" Then
strBuildCriteria = Right(strBuildCriteria, Len(strBuildCriteria) -
2)
strAppellation = "Appellation: " & strBuildCriteria
Else
strAppellation = ""
End If 'strips out superfluous leading comma and space
strWhere = strWhere & strBuildString & ") "
End If
'Search string components have been built
'So let's put them all together now...
strFullString = strFullString & strWhere & strOrderBy
Set intSelItem = Nothing
strChk = ""
strDelim = ""
strWhere = ""
strFrom = ""
Set frm = Nothing
BuildSearchString = True
Exit_BuildSearchString:
Exit Function
Err_BuildSearchString:
MsgBox Err.Description
Resume Exit_BuildSearchString
End Function
Function BuildResultsTable(strFullString As String) As Boolean
Dim db As DAO.Database
Dim qdfAppend As DAO.QueryDef
Dim qdfTruncate As DAO.QueryDef
Dim strTruncate As String
Set db = CurrentDb()
'Delete previous search results before appending new search results to
tblSearchResults table
strTruncate = "DELETE zstblSearchResults.* FROM zstblSearchResults;"
On Error Resume Next
Set qdfTruncate = db.CreateQueryDef("", strTruncate)
qdfTruncate.Execute dbFailOnError
qdfTruncate.Close
On Error GoTo 0
'Append new search results
strFullString = "INSERT INTO zstblSearchResults " & strFullString
Set qdfAppend = db.CreateQueryDef("", strFullString)
qdfAppend.Execute dbFailOnError
lngRecordsAffected = qdfAppend.RecordsAffected
qdfAppend.Close
Set qdfTruncate = Nothing
Set qdfAppend = Nothing
Set db = Nothing
BuildResultsTable = True
End Function
Function DisplayResults(lngRecordsAffected As Long) As Boolean
'Declarations
Dim frm As Form
Dim intReturn As Integer
Dim strMsg As String
Dim strRpt As String
Dim strQueryName As String
Dim strSheetName As String
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlSheet2 As Excel.Worksheet
Dim xlRange As Excel.Range
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim critVar As Variant
Dim CriteriaGroup(1 To 17) As String
Set frm = Forms("frmReportsMain")
Select Case lngRecordsAffected
Case 0
strMsg = "No wines matched the criteria you specified."
MsgBox strMsg, vbExclamation, Application.Name
DisplayResults = True
Exit Function
Case 1
strMsg = "Your search returned 1 wine."
strMsg = strMsg & vbCrLf & vbCrLf & "Would you like to proceed?"
Case Is > 1
strMsg = "Your search returned " & lngRecordsAffected & " wines."
strMsg = strMsg & vbCrLf & vbCrLf & "Would you like to proceed?"
End Select
intReturn = MsgBox(strMsg, _
vbQuestion + vbYesNo + vbDefaultButton1, _
Application.Name)
If intReturn = vbYes Then
'Declare string parameters to insert into reusable procedure...
Select Case frm.cboReportType
Case 1
strRpt = ""
strQueryName = "qryWinesAtAGlanceRpt"
strSheetName = "Wines at a Glance"
Case 2
strRpt = ""
strQueryName = "qryWineListRpt"
strSheetName = "Wine List"
Case 3
strRpt = ""
strQueryName = "qryBlendRpt"
strSheetName = "Blend Report"
Case 4
strRpt = ""
strQueryName = "qryProducerListRpt"
strSheetName = "Producer List"
End Select
'Run report depending on format selecttion...
Select Case frm.cboFormatType
Case 1
'DoCmd.OpenForm strRpt, acNormal
Case 2
DoCmd.Hourglass True
CriteriaGroup(1) = strWineType
CriteriaGroup(2) = strVarietal
CriteriaGroup(3) = strVintage
CriteriaGroup(4) = strWineStyle
CriteriaGroup(5) = strReserve
CriteriaGroup(6) = strUnfiltered
CriteriaGroup(7) = strUnoaked
CriteriaGroup(8) = strStartDate
CriteriaGroup(9) = strEndDate
CriteriaGroup(10) = strMinPrice
CriteriaGroup(11) = strMaxPrice
CriteriaGroup(12) = strMinRating
CriteriaGroup(13) = strMaxRating
CriteriaGroup(14) = strCountry
CriteriaGroup(15) = strState
CriteriaGroup(16) = strRegion
CriteriaGroup(17) = strAppellation
'First, we need to build criteria strings and insert them into Excel
'Set xlApp = CreateObject("Excel.Application")
Set xlApp = New Excel.Application
Set xlWorkbook = xlApp.Workbooks.Add
Set xlSheet = xlWorkbook.Worksheets.Add
With xlSheet.Cells(1, 1)
.Value = "Search Criteria Selected:"
.Font.Bold = True
End With
x = 3
For Each critVar In CriteriaGroup
If critVar <> "" Then
With xlSheet
.Cells(x, 1).Value = critVar
End With
x = x + 1
End If
Next critVar
xlSheet.Columns.AutoFit
xlSheet.Name = "Search Criteria"
'Now that we have criteria built into worksheet,
'we need to export the actual data that matched criteria
'BEGINNING OF ORIGINAL CODE...
Set db = CurrentDb()
Set rst = db.OpenRecordset(strQueryName)
Set xlSheet2 = xlWorkbook.Worksheets.Add
'Set xlSheet = xlWorkbook.Sheets.Add
'Set xlSheet = xlWorkbook.Sheets.(1)
y = 1
For Each fld In rst.Fields
With xlSheet2
.Cells(1, y).Value = fld.Name
.Cells(1, y).Font.Bold = True
End With
y = y + 1
Next fld
Set xlRange = xlSheet2.Cells(2, 1)
xlRange.CopyFromRecordset rst
xlSheet2.Name = strSheetName 'Or just create a straight forward name
surrounded by double quotes like a string
xlSheet2.Columns.AutoFit
rst.Close
'Run some customized formatting depending on report type...
Select Case frm.cboReportType
Case 1
Set xlRange = xlSheet2.Columns("T:T")
xlRange.NumberFormat = "$#,##0.00"
Set xlRange = xlSheet2.Columns("AD:AD")
xlRange.NumberFormat = "0.0%"
Set xlRange = xlSheet2.Columns("AF:AF")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AJ:AJ")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AK:AK")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AL:AL")
xlRange.NumberFormat = "0.00"
Set xlRange = xlSheet2.Columns("AM:AM")
xlRange.NumberFormat = "0.0"
Case 2
Set xlRange = xlSheet2.Columns("E:E")
xlRange.NumberFormat = "$#,##0.00"
Set xlRange = xlSheet2.Columns("F:F")
xlRange.NumberFormat = "0.00"
Case 3
Case 4
Set xlRange = xlSheet2.Columns("C
")xlRange.NumberFormat = "[<=9999999]###-####;(###) ###-####"
End Select
xlApp.Visible = True
DoCmd.Hourglass False
End Select
End If
'Previous code for clearing out hanging criteria strings was located here...
'Run clear procedure again to clear up some memory...
Call ClearSearchStrings
strQueryName = ""
strSheetName = ""
Set frm = Nothing
Set critVar = Nothing
Erase CriteriaGroup()
Set fld = Nothing
Set rst = Nothing
Set db = Nothing
Set xlRange = Nothing
Set xlSheet2 = Nothing
Set xlSheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing
DisplayResults = True
End Function