Ok So here is my code. I think I'm close but when the frmCondition/Concerns Update form opens it ask for the strCBOProperty value. I know it is probably a syntax error, but I don't know what it is.
Private Sub btnLogin_Click()
Dim strCBOPassword As String
Dim strPassword As String
Dim strCBOProperty As String
Selectnull
strCBOProperty = Me.cboProperty.Column(0)
strCBOPassword = Me.cboProperty.Column(1)
strPassword = Me.txtPassword
If strCBOPassword = strPassword Then
MsgBox "Login Successful!"
DoCmd.BrowseTo acBrowseToForm, "frmCondition/Concerns Update", , "[Forms]![frmCondition/Concerns Update]!cbopropertyname = strCBOProperty"
Else
MsgBox "Invalid Password"
End If
End Sub
Private Sub Selectnull()
If IsNull(Me.cboProperty) Then
MsgBox "Please select a property", vbOKOnly
ElseIf IsNull(Me.txtPassword) Then
MsgBox "Please enter a password", vbOKOnly
End If
End Sub
I'd say you need something like this:
DoCmd.OpenForm "frmCondition", WhereCondition:="PropertyName='" & Me.cboProperty.Value & "'"
If not, tell us more about the contents of cboProperty and the data type of the property column in the conditions table.
If you have the value in a variable:
DoCmd.OpenForm "frmCondition", WhereCondition:="PropertyName='" & strCBOProperty & "'"
The variable must be outside of the string.
Using named parameters makes sure you get the parameter right. You have it on the FilterName position.
I edited code by referring to How do I access the selected rows in Access?. But I got runtime error of 3021 at RS.Move F.SelTop - 1 with my code even though m_SelNumRecs is not zero. I am not sure if I have to add additional code to my code.
I have a form including a subform of frm_SubPerson. I select record(s) on the frm_SubPerson and want to conver the record(s) into pdf.
Public m_SelNumRecs As Long
Public m_SelTopRec As Long
Public m_CurrentRec As Long
Private Sub cmdConvert()
Dim mSelTop As Long
Dim mSelHeight As Long
Dim F As Form
Dim RS As Recordset
Dim filePath As String
Dim i As Integer
' Get the form and its recordset.
Set F = Me.frm_SubPerson.Form
Set RS = F.RecordsetClone
If m_SelNumRecs = 0 Then
MsgBox "no record is selected."
Exit Sub
End If
' Move to the first selected record.
RS.Move F.SelTop - 1 '3021 error
For i = 1 To m_SelNumRecs
DoCmd.OpenReport "report_Person", acViewPreview, , "report_Person.chName=" & "'" & RS!chName.Value & "'"
filePath = "D:\report_Person\" & "report_Person" & RS!chName & "_" & RS!chNum & "_" & RS!reYear.Value & "Year" & RS!reMonth & "Month" & ".pdf"
DoCmd.OutputTo acOutputReport, "", acFormatPDF, filePath
DoCmd.Close acReport, "report_Person"
RS.MoveNext
Next i
RS.Close
Set RS = Nothing
End Sub
Private Sub frm_SubPerson_Exit(Cancel As Integer)
With frm_SubPerson.Form
m_SelNumRecs = .SelHeight
m_SelTopRec = .SelTop
m_CurrentRec = .CurrentRecord
End With
End Sub
In my office of 65 people, I want to create a "portal" for all the employees out of a single .accdb file. It will allow each employee to navigate to a new "screen" from a dropdown menu.
Should I use a single form with plug-and-play subform controls in order to centralize the VBA code, or should I just use different forms?
I'm thinking it would be nice to have one form with plug-and-play subform controls. When the employee selects a new "screen", the VBA just sets the SourceObject property of each subform control and then re-arranges the subforms based on the layout of the selected "screen".
For instance, we currently use a couple of Access database forms to enter and review errors that we find in our workflow system. So in this scenario, to review the errors I would just say
SubForm1.SourceObject = "Form.ErrorCriteria"
SubForm2.SourceObject = "Form.ErrorResults"
And then I would just move them into place (these values would be pulled dynamically based upon the "screen" selected):
SubForm1.Move WindowWidth * 0.05, WindowHeight * 0.05, WindowWidth * 0.9, WindowHeight * 0.2
SubForm2.Move WindowWidth * 0.05, WindowHeight * 0.25, WindowWidth * 0.9, WindowHeight * 0.65
So this creates a small header section (SubForm1) on the form where I can select the criteria for the errors I want to see (data range, which team committed the error, etc) and then I can view the errors in the much larger section below the header (SubForm2) that holds the datasheet with the results.
I can propogate events up to the main form from the ErrorCriteria and ErrorResults forms that are now bound to the subform controls. That will help me to use the basic MVC design pattern for VBA described here. I can treat the main form as the view, even though parts of that view are buried in subform controls. The controller only has to know about that one view.
My problem comes when the user selects a new "screen" from the dropdown menu. I think it would be nice to just re-purpose the subform controls, like so:
SubForm1.SourceObject = "Form.WarehouseCriteria"
SubForm2.SourceObject = "Form.InventoryResults"
And then just move/resize those subforms to the appropriate layout for the "Inventory" screen.
This approach seems to make the user interface design cleaner in my mind because you basically only ever have to deal with one main form that acts as a template and then you plug in the values (the SourceObject properties) into that template.
But each time we change the "screen", we have a totally different "Model" behind the scenes and a new "View" too according to the MVC design pattern. I wonder if that would clutter up the MVC VBA code behind the scenes, or if the VBA code itself could be modularized too (possibly using Interfaces) to make it just as adaptable as the user interface.
What is the cleanest way to do this from both a User Interface perspective, and from a VBA perspective. Use one main form as template where other forms could be swapped in and out as subforms, or just close the current form and open a new form when the user selects a new "screen" from the dropdown menu.
Below is a brief description of one way to 'repurpose' or reformat a form for several uses. Re your question of changing the VBA code, a simple solution would be to check a label value or some value you set in the control, then call the appropriate VBA subroutine.
We had over 100 reports available, each with their own selection criteria/options and we did not want to create a unique filter form for every report. The solution was to identify the selection options available by report, identify the logical order of those options, then create a table that would present the options to the user.
First, we created the table: ctlReportOptions (PK = ID, ReportName, OptionOrder)
Fields: ID (Int), ReportName (text), OptionOrder (Int), ControlName (text), ControlTop (Int), ControlLeft (Int), SkipLabel (Y/N), ControlRecordsourc(text)
Note 1: ID is not an AutoNumber.
Next we populated with records that would define the view the user would see.
Note 2: Using an ID of zero, we created records for EVERY field on the report so we could always redraw for the developers.
Then we created the form and placed controls for every possible filter.
We set the 'Default Value' property to be used as our default.
Some of the controls:
ComboBox to select the report name. Add code for Change event as follows:
Private Sub cboChooseReport_Change()
Dim strSQL As String
Dim rs As ADODB.recordSet
Dim i As Integer
Dim iTop As Integer
Dim iLeft As Integer
Dim iLblTop As Integer
Dim iLblLeft As Integer
Dim iLblWidth As Integer
Dim iTab As Integer
Dim strLabel As String
On Error GoTo Error_Trap
' Select only optional controls (ID <> 0); skip cotrols always present.
strSQL = "SELECT ctlRptOpt.ControlName, 'lbl' & Mid([ControlName],4,99) AS LabelName, SkipLabel " & _
"From ctlRptOpt WHERE (((ctlRptOpt.ID)<>0)) " & _
"GROUP BY ctlRptOpt.ControlName, 'lbl' & Mid([ControlName],4,99), SkipLabel;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
Do While Not rs.EOF
Me(rs!ControlName).Visible = False ' Hide control
If rs!skiplabel = False Then ' Hide Label if necessary
Me(rs!LabelName).Visible = False
End If
rs.MoveNext
Loop
rs.Close
iTop = 0
iTab = 0
' Get list of controls used by this report; order by desired sequence.
strSQL = "select * from ctlRptOpt " & _
"where [ID] = " & Me.cboChooseReport.Column(3) & _
" order by OptionOrder;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
If rs.EOF Then ' No options needed
Me.cmdShowQuery.Visible = True
Me.lblReportCriteria.Visible = False
Me.cmdShowQuery.left = 2000
Me.cmdShowQuery.top = 1500
Me.cmdShowQuery.TabIndex = 1
Me.cmdReset.Visible = False
rs.Close
Set rs = Nothing
GoTo Proc_Exit ' Exit
End If
' Setup the display of controls.
Me.lblReportCriteria.Visible = True
Do While Not rs.EOF
If rs!skiplabel = False Then
strLabel = "lbl" & Mid(rs!ControlName, 4)
iLblWidth = Me.Controls(strLabel).Width
Me(strLabel).top = rs!ControlTop
Me(strLabel).left = rs!ControlLeft - (Me(strLabel).Width + 50)
Me(strLabel).Visible = True
End If
iTab = iTab + 1 ' Set new Tab Order for the controls
Me(rs!ControlName).top = rs!ControlTop
Me(rs!ControlName).left = rs!ControlLeft
Me(rs!ControlName).Visible = True
If left(rs!ControlName, 3) <> "lbl" Then
Me(rs!ControlName).TabIndex = iTab
End If
If Me(rs!ControlName).top >= iTop Then
iTop = rs!ControlTop + Me(rs!ControlName).Height ' Save last one
End If
' If not a label and not a 'cmd', it's a filter! Set a default.
If left(rs!ControlName, 3) <> "lbl" And left(rs!ControlName, 3) <> "cmd" Then
If Me(rs!ControlName).DefaultValue = "=""*""" Then
' Me(rs!ControlName) = "*"
ElseIf left(Me(rs!ControlName).DefaultValue, 2) = "=#" And right(Me(rs!ControlName).DefaultValue, 1) = "#" Then
i = Len(Me(rs!ControlName).DefaultValue)
' Me(rs!ControlName) = Mid(Me(rs!ControlName).DefaultValue, 3, i - 3)
ElseIf Me(rs!ControlName).DefaultValue = "True" Then
' Me(rs!ControlName) = True
ElseIf Me(rs!ControlName).DefaultValue = "False" Then
' Me(rs!ControlName) = False
End If
Else
If Me(rs!ControlName).top + Me(rs!ControlName).Height >= iTop Then
iTop = rs!ControlTop + Me(rs!ControlName).Height ' Save last one
End If
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
If Me.cboChooseReport.Column(1) <> "rptInventoryByDate" Then ' It's special
Me.cmdShowQuery.Visible = True
Me.cmdShowQuery.left = 2000
Me.cmdShowQuery.top = iTop + 300
iTab = iTab + 1
Me.cmdShowQuery.TabIndex = iTab
Else
Me.cmdShowQuery.Visible = False
End If
Me.cmdReset.Visible = True
Me.cmdReset.left = 5000
Me.cmdReset.top = iTop + 300
Me.cmdReset.TabIndex = iTab + 1
Proc_Exit:
Exit Sub
Error_Trap:
Err.Source = "Form_frmReportChooser: cboChooseReport_Change at Line: " & Erl
DocAndShowError ' Save error to database for analysis, then display to user.
Resume Proc_Exit ' Exit code.
Resume Next ' All resumption if debugging.
Resume
End Sub
lblReportCriteria: We displayed the final set of filters so when users complained of nothing showing on the report, we asked them to send us a screen print. We also passed this text to the report and it was printed as a footer on the last page.
cmdReset: Reset all controls back to their default values.
cmdShowQuery: Executes the running of the report
Private Sub cmdShowQuery_Click()
Dim qdfDelReport101 As ADODB.Command
Dim qdfAppReport101 As ADODB.Command
Dim qdfDelReport102 As ADODB.Command
Dim qdfAppReport102 As ADODB.Command
Dim qryBase As ADODB.Command
Dim strQueryName As String
Dim strAny_Open_Reports As String
Dim strOpen_Report As String
Dim qdfVendorsInfo As ADODB.Command
Dim rsVendorName As ADODB.recordSet
Dim strVendorName As String
Dim rsrpqFormVendorsInfo As ADODB.recordSet
On Error GoTo Error_Trap
If Not IsNull(Me.cboChooseReport.value) And Me.cboChooseReport.value <> " " Then
strAny_Open_Reports = Any_Open_Reports()
If Len(strAny_Open_Reports) = 0 Then
If Me.cboChooseReport.value = "rptAAA" Then
BuildReportCriteria '
If Me.chkBankBal = True Then
DoCmd.OpenReport "rptAAA_Opt1", acViewPreview
Else
DoCmd.OpenReport "rptAAA_Opt2", acViewPreview
End If
ElseIf Me.cboChooseReport.value = "rptBBB" Then
If IsNull(Me.txtFromDate) Or Not IsDate(Me.txtFromDate) Then
MsgBox "You must enter a valid From Date", vbOKOnly, "Invalid Date"
Exit Sub
End If
If IsNull(Me.txtToDate) Or Not IsDate(Me.txtToDate) Then
MsgBox "You must enter a valid To Date", vbOKOnly, "Invalid Date"
Exit Sub
End If
Me.txtStartDate = Me.txtFromDate
Me.txtEndDate = Me.txtToDate
DoCmd.OpenReport Me.cboChooseReport.value, acViewPreview
ElseIf Me.cboChooseReport.value = "rptCCC" Then
If Me.txtVendorName = "*" Then
gvstr_VendorName = "*"
Else
Set rsVendorName = New ADODB.recordSet
rsVendorName.Open "selVendorName", gv_DBS_Local, adOpenDynamic
Set qdfVendorsInfo = New ADODB.Command
qdfVendorsInfo.ActiveConnection = gv_DBS_SQLServer
qdfVendorsInfo.CommandText = ("qryVendorsInfo")
qdfVendorsInfo.CommandType = adCmdStoredProc
strVendorName = rsVendorName("VendorName")
gvstr_VendorName = strVendorName
End If
DoCmd.OpenReport "rptFormVendorReport", acViewPreview
Else
BuildReportCriteria
If Me.cboChooseReport.value = "rptXXXXXX" Then
ElseIf Me.cboChooseReport.value = "rptyyyy" Then
On Error Resume Next ' All resumption if debugging.
DoCmd.DeleteObject acTable, "temp_xxxx"
On Error GoTo Error_Trap
Set qryBase = New ADODB.Command
qryBase.ActiveConnection = gv_DBS_Local
qryBase.CommandText = ("mtseldata...")
qryBase.CommandType = adCmdStoredProc
qryBase.Execute
End If
DoCmd.Hourglass False
DoCmd.OpenReport Me.cboChooseReport.value, acViewPreview
End If
Else
MsgBox "You cannot open this form/report because you already have a form/report(s) open: " & _
vbCrLf & strAny_Open_Reports & _
vbCrLf & "Please close the open form/report(s) before continuing."
strOpen_Report = Open_Report
DoCmd.SelectObject acReport, strOpen_Report
DoCmd.ShowToolbar "tbForPost"
End If
Else
MsgBox "Please Choose Report", vbExclamation, "Choose Report"
End If
Exit Sub
Error_Trap:
Err.Source = "Form_frmReportChooser: cmdShowQuery_Click - Report: " & Nz(Me.cboChooseReport.value) & " at Line: " & Erl
If Err.Number = 2501 Then ' MsgBox "You chose not to open this report.", vbOKOnly, "Report cancelled"
Exit Sub
ElseIf Err.Number = 0 Or Err.Number = 7874 Then
Resume Next ' All resumption if debugging.
ElseIf Err.Number = 3146 Then ' ODBC -- call failed -- can have multiple errors
Dim errLoop As Error
Dim strError As String
Dim Errs1 As Errors
' Enumerate Errors collection and display properties of each Error object.
i = 1
Set Errs1 = gv_DBS_SQLServer.Errors
Err.Description = Err.Description & "; Err.Count = " & gv_DBS_SQLServer.Errors.Count & "; "
For Each errLoop In Errs1
With errLoop
Err.Description = Err.Description & "Error #" & i & ":" & " ADO Error#" & .Number & _
" Description= " & .Description
i = i + 1
End With
Next
End If
DocAndShowError ' Save error to database for analysis, then display to user.
Exit Sub
Resume Next ' All resumption if debugging.
Resume
End Sub
Function to build a string showing all of the selection criteria:
Function BuildReportCriteria()
Dim frmMe As Form
Dim ctlEach As Control
Dim strCriteria As String
Dim prp As Property
Dim strSQL As String
Dim rs As ADODB.recordSet
On Error GoTo Error_Trap
strSQL = "select * from ctlRptOpt " & _
"where ID = " & Me.cboChooseReport.Column(3) & _
" order by OptionOrder;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
If rs.EOF Then
strCriteria = " Report Criteria: None"
Else
strCriteria = " Report Criteria: "
End If
Do While Not rs.EOF
Set ctlEach = Me.Controls(rs!ControlName)
If ctlEach.ControlType = acTextBox Or ctlEach.ControlType = acComboBox Then
If ctlEach.value <> "*" And ctlEach.Name <> "cboChooseReport" And ctlEach.Name <> "cboLocCountry" Then
strCriteria = strCriteria & ctlEach.Tag & " = " & ctlEach.value & " , "
End If
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
If Me.chkOblBal = -1 Then
strCriteria = strCriteria & "Non-zero balances only = Yes"
Else
'return string with all choosen criteria and remove last " , " from the end of string
strCriteria = left$(strCriteria, Len(strCriteria) - 3)
End If
fvstr_ReportCriteria = strCriteria
Set ctlEach = Nothing
Exit Function
Error_Trap:
If Err.Number = 2447 Then
Resume Next ' All resumption if debugging.
End If
Err.Source = "Form_frmReportChooser: BuildReportCriteria at Line: " & Erl
DocAndShowError ' Save error to database for analysis, then display to user.
Exit Function
Resume Next ' All resumption if debugging.
End Function
Finally, each report had it's own query that would filter based on the values in the controls on this form.
Hope this helps. If you are curious about any of the weird things you see, let me know. (i.e. we always used line numbers in the code (I deleted before posting) that allowed us to identify exact line where code fails)
I have a button in my Access 2007 form. On click, I need to open filedialog. I dont know how to attach the file selected to the 'Memo' field of a table using DAO.
Form details
Form : OrderForm
Field: txtManagerProfile
Button : btnFileBrowse
Table details
Table :ManagersProfile
Memo field : Profile
Requirement:
'Profile' in table should accept any file and save it. Once the user selects the file, I need to show a open icon near to the 'txtManagerProfile' field in the form. On clicking the open button , I need to open any file. I am not used to this requirement before. Someone pls help. I am using DAO for populating other fields in the form.
In the below code I have a form with a text box named txtManagerProfile and a button named btnFileBrowse. When I click on the btnFileBrowse button a browser pops up that lets you browse to the file. When you select the file, the path is stored in the txtManagerProfile text box. If you double click on the txtManagerProfile text box the file gets opened up.
Here is the code behind the form:
'the open filename api
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As gFILE) As Long
' the gFILE type needed by the open filename api
Private Type gFILE
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Function FileToOpen(Optional StartLookIn) As String
'Purpose: Calls the open file api to let the user select the file to open
'returns: string value which contains the path to the file selected. "" = no file seleted
Dim ofn As gFILE, Path As String, filename As String, a As String
ofn.lStructSize = Len(ofn)
ofn.lpstrFilter = "All Files (*.*)"
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
If Not IsMissing(StartLookIn) Then ofn.lpstrInitialDir = StartLookIn Else ofn.lpstrInitialDir = "f:\Quoting"
ofn.lpstrTitle = "SELECT FILE"
ofn.Flags = 0
a = GetOpenFileName(ofn)
If (a) Then
Path = Trim(ofn.lpstrFile)
filename = Trim(ofn.lpstrFileTitle)
If Dir(Path) <> "" Then
FileToOpen = -1
FileToOpen = Trim(ofn.lpstrFile)
Else
FileToOpen = ""
Path = ""
filename = ""
End If
End If
FileToOpen = Path
End Function
Private Sub btnFileBrowse_Click()
Dim MyPath As String
MyPath = FileToOpen
If (VBA.Strings.Len(MyPath & "") > 0) Then txtManagerProfile = MyPath
End Sub
Private Sub txtManagerProfile_DblClick(Cancel As Integer)
On Error GoTo Err_My_Click
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
'IF THE FILE DOES NOT EXIST THEN DISPLAY THE MESSAGE AND EXIT THE SUBROUTINE
If (fso.FileExists(txtManagerProfile) = False) Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
Exit Sub
End If
'USED TO CHECK IF THE FILE IS ALREADY OPENED AND LOCKED BY ANOTHER USER.
Open txtManagerProfile For Binary Access Read Write Lock Read Write As #1
Close #1
Application.FollowHyperlink txtManagerProfile
Exit_My_Click:
Exit Sub
Err_My_Click:
If Err.Number = 486 Then
MsgBox "YOU DO NOT HAVE THE PROGRAM INSTALLED THAT " & vbNewLine & _
"IS USED TO VIEW THIS FILE. CONTACT YOUR IT " & vbNewLine & _
"MANAGER AND HAVE HIM/HER INSTALL THE NEEDED " & vbNewLine & _
"APPLICATION.", , "ERROR: MISSING APPLCIATION"
ElseIf Err.Number = 490 Then
MsgBox "THE FILE PATH IS INCORRECT.", , "ERROR: INVALID FILE PATH"
ElseIf Err.Number = 70 Or Err.Number = 75 Then
MsgBox "THE FILE IS OPENED/LOCKED BY ANOTHER USER." & vbNewLine & _
"THEY WILL HAVE TO CLOSE IT BEFORE YOU CAN " & vbNewLine & _
"OPEN IT THROUGH PDC.", , "ERROR: FILE ALREADY OPEN"
Else
MsgBox ("ERROR MESSAGE: " & Err.Description & vbNewLine & _
"ERROR NUMBER: " & Err.Number & vbNewLine & _
"ERROR SOURCE: " & Err.Source)
End If
Resume Exit_My_Click
End Sub
EDIT:
You could do something like the following to save the path into a table somewhere:
Private Sub cmdSave_Click()
If (VBA.Strings.Len(txtManagerProfile & "") <> 0) Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO MyTable (linkfile) VALUES ('" & _
txtManagerProfile & "')"
DoCmd.SetWarnings True
MsgBox "SUCCESSFULLY SAVED", , "SUCCESS"
Else
MsgBox "YOU MUST SELECT A FILE FIRST BEFORE SAVING", , "ERROR: NO FILE"
End If
End Sub
Having a very weird problem. I have a function which is called when a form field gets focus. The function is passed four arguments, three of which are values from form fields and the fourth is a global variable which is set when the form loads. The function uses these variables to calculate the value for the field which called the function. This function is called in two different places. Everything was working fine, and now suddenly the function works when called from one place and doesn't work from the other, generating a 2467 run-time error, 'The expression you entered refers to an object that is closed or doesn't exists'. I've checked that the values of the arguments being passed are correct, the function exists OK, so can't see why I'm getting this error. Anyone any ideas?
Private Sub cboFinalStage_GotFocus()
'lookup stage based on TNM values
cboFinalStage = FindStage(cboFinalStageT, cboFinalStageN, cboFinalStageM, gblCancer)
End Sub
Public Function FindStage(cboT As ComboBox, cboN As ComboBox, cboM As ComboBox,
strCancer As String) As String
'use the TNM values entered to find the correct stage for the site and return it
'error handling
If gcfHandleErrors Then On Error GoTo PROC_ERR
'declare variables
Dim strTemp As String
Dim strTable As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strQuery As String
Dim strSite As String
Dim strSiteFull As String
Dim strT As String
Dim strN As String
Dim strM As String
'initialise variables - if there are no values entered in the 3 comboboxes, exit
'load tumour first in case it isn't already loaded
Forms!frmContainer.subTumour.SourceObject = "fsubTumour"
If Not IsNull(Forms!frmContainer.subTumour.Form!txtICD10) Then
strSite = Left(Forms!frmContainer.subTumour.Form!txtICD10, 3)
strSiteFull = Forms!frmContainer.subTumour.Form!txtICD10
End If
If Not IsNull(cboT.Value) Then
strT = cboT.Value
Debug.Print "T is " & strT
End If
If Not IsNull(cboN.Value) Then
strN = cboN.Value
Debug.Print "N is " & strN
End If
If Not IsNull(cboM.Value) Then
strM = cboM.Value
Debug.Print "M is " & strM
End If
If (IsNull(strT) Or IsNull(strN) Or IsNull(strM)) Then
Debug.Print "null so exiting"
Exit Function
End If
'identify the correct AJCC lookup table by cancer site
Select Case [strCancer]
Case "bla"
strTable = "lkp_AJCC_bladder"
Case "bre"
strTable = "lkp_AJCC_breast"
...
End Select
Debug.Print "AJCC table is " & strTable
'query the AJCC lookup table for the stage
strQuery = "SELECT c_stage FROM " & strTable & " WHERE (((t_value)='" & strT & "')
AND ((n_value)='" & strN & "') AND ((m_value)='" & strM & "'))"
Debug.Print "query is " & strQuery
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
If Not rs.EOF Then
strTemp = rs.Fields(0).Value
Debug.Print "result is " & strTemp
End If
rs.Close
db.Close
'return stage
FindStage = strTemp
'error handling
PROC_EXIT:
Exit Function
PROC_ERR:
If (Err.Number = 2467) Then
MsgBox "Unable to evaluate the stage", vbOKOnly, "Processing error"
Resume PROC_EXIT
Else
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume PROC_EXIT
End If
End Function