Attribute VB_Name = "modPublicInterface"
Option Compare Database ' declare the default string comparison method based on the sort order of the database
Option Explicit         ' Makes the programmer declare all variables
Option Base 0           ' Explicitly sets the lower bound of arrays to zero
'
' Public interface subroutines are used throughout the application to standardize actions

Sub GetFormNameTitle(lngInput As Long, strFormName As String, strFormTitle As String, strOpenArg As String)
'
' Purpose:
' To provide form titles and form names to launch the right form in context
' History:
' Version 1.0 June 21 2008 by Gregory E. Granato
' Arguments:
'
' lngInput input index number
' strFormName output form name used with open command
' strFormTitle output form title to communicate with reader
'
Select Case lngInput

Case 0  ' Splash-screen open form
 strFormName = "frmOpen"
 strFormTitle = "SELDM Splash Screen"
 strOpenArg = ""

Case 1 ' Analyst form
 strFormName = "frmAnalyst"
 strFormTitle = "Analyst Identification Form"
 strOpenArg = ""
 
Case 2 ' Project form
 strFormName = "frmProject"
 strFormTitle = "Project Identification Form"
 strOpenArg = ""

Case 3 ' Analysis status/copy form
 strFormName = "frmAnalysis"
 strFormTitle = "Analysis Identification Form"
 strOpenArg = ""

Case 4 ' Highway Site input form
 strFormName = "frmHighwaySite"
 strFormTitle = "Highway Site Identification Form"
 strOpenArg = ""
 
Case 5 ' GIS Grid Form
 strFormName = "frmGISGrid"
 strFormTitle = "GIS Grid Identification Form"
 strOpenArg = ""
 
Case 6 ' Ecoregion Form
 strFormName = "frmEcoregion"
 strFormTitle = "Ecoregion Identification Form"
 strOpenArg = ""
 
Case 7 ' Upstream Basin Form
 strFormName = "frmUpstreamBasin"
 strFormTitle = "Upstream Basin Identification Form"
 strOpenArg = ""
 
Case 8 ' Lake Basin Form
 strFormName = "frmLakeBasin"
 strFormTitle = "Lake Basin Identification Form"
 strOpenArg = ""
 
Case 9 ' Precipitation Statistics Selection Form
 strFormName = "frmPrecipSelect"
 strFormTitle = "Precipitation Statistics Selection Form"
 strOpenArg = ""
 
Case 10 ' Precipitation site selection form
 strFormName = "frmPrecipGetSites"
 strFormTitle = "Precipitation Statistics Site Selection Form"
 strOpenArg = ""
 
Case 11 ' Streamflow Statistics Selection  Form
 strFormName = "frmStreamflowSelect"
 strFormTitle = "Streamflow Statistics Selection Form"
 strOpenArg = ""
 
Case 12 ' Streamflow site selection form
 strFormName = "frmStreamflowGetSites"
 strFormTitle = "Streamflow Statistics Site Selection Form"
 strOpenArg = ""
 
Case 13 ' Rv Statistics Selection  Form
 strFormName = "frmRvSelect"
 strFormTitle = "Runoff Coefficient Statistics Selection Form"
 strOpenArg = ""
 
Case 14 ' Water-quality selection menu form
 strFormName = "frmQWMenu"
 strFormTitle = "Water Quality: Constituent Selection Form"
 strOpenArg = ""
   
Case 15 ' Define random water quality
 strFormName = "frmQWRandom"
 strFormTitle = "Water Quality: Random Statistics Selection Form"
 strOpenArg = ""
  
Case 16 ' Define dependent/transport curve
 strFormName = "frmQWDependent"
 strFormTitle = "Water Quality: Regression Statistics Selection Form"
 strOpenArg = ""
 
Case 17 ' Define Constituent Pairs
 strFormName = "frmQWDefinePairs"
 strFormTitle = "Water Quality: Define Constituent-Pairs for Downstream Analysis"
 strOpenArg = ""
 
Case 20 ' Define BMP
 strFormName = "frmBMPDefinition"
 strFormTitle = "BMP: Best Management Practice Performance "
 strOpenArg = ""
 
Case 21 'Run Analysis Form
 strFormName = "frmRunAnalysis"
 strFormTitle = "SELDM: Run Analysis "
 strOpenArg = ""
 
End Select
 
End Sub
Public Sub CheckVariablesByLocation(lngMyOriginForm As Long, intReturnError As Integer)
'
' Purpose:
' To check common variable assignment based on the location in the input structure
' If a variable is not assigned return to the necessary form
' History:
' Version 1.0 Oct 31 2008 by Gregory E. Granato
'
' lngMyOriginForm As Long          ' Origin form index number
' intReturnError As Integer        ' Return error to close origin form
 
Dim lngOriginForm As Long     ' Destination form index number

lngOriginForm = lngMyOriginForm
intReturnError = 0

' Ensure that we are in the right place in the sequence of input events
 If lMyAnalystID <= 0 Then
  MsgBox "The user must select/define an Analyst", vbCritical, "Please set current Analyst"
  lWhereAmI = 1
  intReturnError = 1
  Exit Sub
 End If
 
 If lWhereAmI < 3 Then Exit Sub
 
 If lMyProject <= 0 Then
  MsgBox "The user must select/define a project", vbCritical, "Please set current Project"
  lWhereAmI = 2
  intReturnError = 1
  Exit Sub
 End If

 If lWhereAmI < 4 Then Exit Sub
  
 If lMyAnalysis <= 0 Then
  MsgBox "The user must select/define an analysis", vbCritical, "Please set current Analysis"
  lWhereAmI = 3
  intReturnError = 1
  Exit Sub
 End If
  
 If lWhereAmI < 5 Then Exit Sub
  
 If lMyHighway <= 0 Then
  MsgBox "The user must select/define a highway site", vbCritical, "Please set current Highway Site"
  lWhereAmI = 4
  intReturnError = 1
  Exit Sub
 End If
  
 If dMyLatVal = 0# And dMyLongVal = 0# Then
  MsgBox "The user must select/define a highway site", vbCritical, "Please set current Highway Site"
  lWhereAmI = 4
  intReturnError = 1
  Exit Sub
 End If
  
 If lWhereAmI < 6 Then Exit Sub
 
 If lMyGISGridCell = 0 Then
  MsgBox "The user must select/define the GIS Grid coordinates first", vbCritical, "Please set current grid"
  lWhereAmI = 5
  intReturnError = 1
  Exit Sub
 End If
 
 If lWhereAmI < 7 Then Exit Sub
 
 If lMyEcoregionID = 0 Then
  MsgBox "The user must select/define the Ecoregion", vbCritical, "Please set current Ecoregion"
  lWhereAmI = 6
  intReturnError = 1
  Exit Sub
 End If
  
 If lWhereAmI < 8 Then Exit Sub
  
 If lMyUpstreamBasin = 0 Then
  MsgBox "The user must select/define the Upstream Basin", vbCritical, "Please set current Upstream Basin"
  lWhereAmI = 7
  intReturnError = 1
  Exit Sub
 End If

If lWhereAmI < 11 Then Exit Sub

 If lMyPrecipStat = 0 Then
  MsgBox "The user must select/define the Precipitation Statistics", vbCritical, "Please set current Precipitation Statistics"
  lWhereAmI = 10
  intReturnError = 1
  Exit Sub
 End If


 If lWhereAmI < 13 Then Exit Sub

 If lMyStreamflowStat = 0 Then
  MsgBox "The user must select/define the Streamflow Statistics", vbCritical, "Please set current Streamflow Statistics"
  lWhereAmI = 11
  intReturnError = 1
  Exit Sub
 End If
 
If lWhereAmI < 14 Then Exit Sub

 If lMyStreamflowStat = 0 Then
  MsgBox "The user must select/define the Runoff Coefficients", vbCritical, "Please set current Runoff Coefficients"
  lWhereAmI = 13
  intReturnError = 1
  Exit Sub
 End If
 
 

End Sub


Public Sub CloseMyForm(lngMyOriginForm As Long, lngMyDestinationForm As Long, lngMyDirection As Long)
'
' Purpose:
' To close the form and return to a previous form
' History:
' Version 1.0 June 20 2008 by Gregory E. Granato
'
' lngMyOriginForm As Long          ' Origin form index number
' lngMyDestinationform As Long     ' Destination form index number
' lngMyDirection As Long           ' Direction (0) backward, (1) forward, or move without prompt (-1)
' (see modPublicInterface.GetFormNameTitle)
'
Dim intMsgBox As Integer               ' Message box return value
Dim strMsgBox As String                ' Message String
Dim strMsgTitle As String              ' Message box prompt
Dim strDestinationName As String       ' Destination form name
Dim strDestinationTitle As String      ' Destination form title
Dim strOriginName As String            ' Origin form name
Dim strOriginTitle As String           ' Origin form title
Dim strOpenArg As String               ' Destination form opening argument
On Error GoTo Err_CloseMyForm

 ' Get origin information
   Call modPublicInterface.GetFormNameTitle(lngMyOriginForm, strOriginName, strOriginTitle, strOpenArg)

 ' Get destination information from the
   Call modPublicInterface.GetFormNameTitle(lngMyDestinationForm, strDestinationName, strDestinationTitle, strOpenArg)
       
 ' Make sure the user really wants to quit the interface
  
 If lngMyDirection = 0 Then ' Move backward
  strMsgTitle = "Close this form and return to the previous form?"
  strMsgBox = "This command button will close the " & vbCrLf & _
  strOriginTitle & vbCrLf & _
  "and go back to the " & vbCrLf & _
  strDestinationTitle & vbCrLf & vbCrLf & _
  "Do you want close the current form now?"
 ElseIf lngMyDirection = 1 Then 'Move forward
  strMsgTitle = "Close this form and move to the next form?"
  strMsgBox = "This command button will close the " & vbCrLf & _
  strOriginTitle & vbCrLf & _
  "and proceed to the " & vbCrLf & _
  strDestinationTitle & vbCrLf & vbCrLf & _
  "Do you want close the current form now?"
 End If

 If lngMyDirection >= 0 Then 'Prompt user
  intMsgBox = MsgBox(strMsgBox, vbYesNo, strMsgTitle)
  If intMsgBox <> 6 Then                   ' if not "Yes" exit sub keep origin open
   Exit Sub
  End If
 End If

 ' Close origin form open destination form
 DoCmd.Hourglass True                   ' set hourglass
 DoCmd.Close acForm, strOriginName
 ' Open next form
 DoCmd.OpenForm strDestinationName, , , , , , strOpenArg

Exit_CloseMyForm:
 Exit Sub

Err_CloseMyForm:
    MsgBox Err.Description, vbCritical, "Close My Form"
    Resume Exit_CloseMyForm
End Sub

Public Sub CheckAnalysisProgress(lngInputAnalysisNumber As Long, intOutputLocation As Integer, _
Optional strOutput As String)
'
' Purpose:
' To check the progress of the current analysis
' History:
' Version 1.0 June 27 2008 by Gregory E. Granato
' Variables:
' lngInputAnalysisNumber As Long input number for selected analysis
' intOutputLocation As Integer ' input number 1: goto progress form 2: Copy routine
' stroutput As String--output to indicate status optional only used if return string is needed
'
' Arguments
Dim bavg As Boolean  ' does average exist
Dim bSD As Boolean   ' does SD exist
Dim bSkew As Boolean ' does Skew exist
Dim bTestQW As Boolean ' does a QW definition exist
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim strSQL As String                    ' Query text
Dim strLinkCriteria As String   ' Link criteria to control form-load events
Dim strAnalysisName As String
Dim strMsgBox As String                 ' MessageBox string
Dim intOutErr As Integer

On Error GoTo Status_Err:
intOutErr = 0
strLinkCriteria = "Status:0000000000000" ' Status:ABCDEFGHIJKLM

Set rstMyRecordset = New ADODB.Recordset

strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblHighwayAnalysis.tAnalysisShortName, " & _
"tblHighwayAnalysis.HighwaySite_ID, tblHighwayAnalysis.dHighwayRvAverage, " & _
"tblHighwayAnalysis.dHighwayRvStandardDeviation, tblHighwayAnalysis.dHighwayRvSkew, " & _
"tblHighwayAnalysis.Ecoregion_ID, tblHighwayAnalysis.PrecipEventStatistics_ID, " & _
"tblHighwayAnalysis.UpstreamBasin_ID, tblHighwayAnalysis.dUpstreamRvAverage, " & _
"tblHighwayAnalysis.dUpstreamRvStandardDeviation, tblHighwayAnalysis.dUpstreamRvSkew, " & _
"tblHighwayAnalysis.StreamflowSelection_ID, tblHighwayAnalysis.bLakeBasinAnalysis, " & _
"tblHighwayAnalysis.LakeDrainageBasin_ID, tblHighwayAnalysis.BMP_ID, " & _
"tblHighwayAnalysis.mAnalysisAbstract " & _
"FROM tblHighwayAnalysis " & _
"WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngInputAnalysisNumber & "));"

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

If IsNull(rstMyRecordset.Fields(0).Value) Then  ' There is no data for this list assign value of 1
 strMsgBox = "Note: The analysis table has no data for the selected project. " & vbCrLf & _
  "Please enter a new analysis."
 MsgBox strMsgBox, vbOKOnly, "Error"
 GoTo CleanUp:
End If

' Get values
  strAnalysisName = rstMyRecordset.Fields(1).Value
' A: Highway-site definition
' *****************
  If (IsNull(rstMyRecordset.Fields(2).Value)) Then
   Mid(strLinkCriteria, 8, 1) = "0"
  ElseIf rstMyRecordset.Fields(2).Value = "" Or rstMyRecordset.Fields(2).Value = 0 Then
   Mid(strLinkCriteria, 8, 1) = "0"
  Else
   Mid(strLinkCriteria, 8, 1) = "1"
  End If
  
' B: Highway-site Rv
' *****************
  ' Average
  If (IsNull(rstMyRecordset.Fields(3).Value)) Then
   bavg = False  'Boolean does average exist
  ElseIf rstMyRecordset.Fields(3).Value = "" Then
   bavg = False  'Boolean does average exist
  Else
   bavg = True  'Boolean does average exist
  End If
  ' standard deviation
  If (IsNull(rstMyRecordset.Fields(4).Value)) Then
   bSD = False   'Boolean does SD exist
  ElseIf rstMyRecordset.Fields(4).Value = "" Then
   bSD = False   'Boolean does SD exist
  Else
   bSD = True  'Boolean does SD exist
  End If
  ' skew
  If (IsNull(rstMyRecordset.Fields(5).Value)) Then
   bSkew = False   'Boolean does SD exist
  ElseIf rstMyRecordset.Fields(5).Value = "" Then
   bSkew = False   'Boolean does SD exist
  Else
   bSkew = True  'Boolean does SD exist
  End If
  
  If (bavg = True) And (bSD = True) And (bSkew = True) Then
   Mid(strLinkCriteria, 9, 1) = "1"
  Else
   Mid(strLinkCriteria, 9, 1) = "0"
  End If
  
' C: Highway-site QW
  ' *****************
  
   bTestQW = bCheckQWfn(lngInputAnalysisNumber, 0)
   If bTestQW = True Then
    Mid(strLinkCriteria, 10, 1) = "1"
   Else
    Mid(strLinkCriteria, 10, 1) = "0"
   End If
  
' D: Highway-site BMP
  ' *****************

  If (IsNull(rstMyRecordset.Fields(15).Value)) Then
   Mid(strLinkCriteria, 11, 1) = "0"
  ElseIf rstMyRecordset.Fields(15).Value = "" Or rstMyRecordset.Fields(12).Value = 0 Then
   Mid(strLinkCriteria, 11, 1) = "0"
  Else
   Mid(strLinkCriteria, 11, 1) = "1"
  End If
    
' E: Ecoregion
' *****************
  If (IsNull(rstMyRecordset.Fields(6).Value)) Then
   Mid(strLinkCriteria, 12, 1) = "0"
  ElseIf rstMyRecordset.Fields(6).Value = "" Or rstMyRecordset.Fields(6).Value = 0 Then
   Mid(strLinkCriteria, 12, 1) = "0"
  Else
   Mid(strLinkCriteria, 12, 1) = "1"
  End If

' F: Precipitation
' *****************
  If (IsNull(rstMyRecordset.Fields(7).Value)) Then
   Mid(strLinkCriteria, 13, 1) = "0"
  ElseIf rstMyRecordset.Fields(7).Value = "" Or rstMyRecordset.Fields(7).Value = 0 Then
   Mid(strLinkCriteria, 13, 1) = "0"
  Else
   Mid(strLinkCriteria, 13, 1) = "1"
  End If
  
' G: Upstream basin definition
' *****************
  If (IsNull(rstMyRecordset.Fields(8).Value)) Then
   Mid(strLinkCriteria, 14, 1) = "0"
  ElseIf rstMyRecordset.Fields(8).Value = "" Or rstMyRecordset.Fields(8).Value = 0 Then
   Mid(strLinkCriteria, 14, 1) = "0"
  Else
   Mid(strLinkCriteria, 14, 1) = "1"
  End If
' H: Upstream basin Rv
' *****************
  ' Average
  If (IsNull(rstMyRecordset.Fields(9).Value)) Then
   bavg = False  'Boolean does average exist
  ElseIf rstMyRecordset.Fields(9).Value = "" Then
   bavg = False  'Boolean does average exist
  Else
   bavg = True  'Boolean does average exist
  End If
  ' standard deviation
  If (IsNull(rstMyRecordset.Fields(10).Value)) Then
   bSD = False   'Boolean does SD exist
  ElseIf rstMyRecordset.Fields(10).Value = "" Then
   bSD = False   'Boolean does SD exist
  Else
   bSD = True  'Boolean does SD exist
  End If
  ' skew
  If (IsNull(rstMyRecordset.Fields(11).Value)) Then
   bSkew = False   'Boolean does SD exist
  ElseIf rstMyRecordset.Fields(11).Value = "" Then
   bSkew = False   'Boolean does SD exist
  Else
   bSkew = True  'Boolean does SD exist
  End If
  
  If (bavg = True) And (bSD = True) And (bSkew = True) Then
   Mid(strLinkCriteria, 15, 1) = "1"
  Else
   Mid(strLinkCriteria, 15, 1) = "0"
  End If
  
' I: Upstream basin QW
' *****************

   bTestQW = bCheckQWfn(lngInputAnalysisNumber, 1)
   If bTestQW = True Then
    Mid(strLinkCriteria, 16, 1) = "1"
   Else
    Mid(strLinkCriteria, 16, 1) = "0"
   End If
  
' J: Upstream basin streamflow
' *****************
 If (IsNull(rstMyRecordset.Fields(12).Value)) Then
   Mid(strLinkCriteria, 17, 1) = "0"
  ElseIf rstMyRecordset.Fields(12).Value = "" Or rstMyRecordset.Fields(12).Value = 0 Then
   Mid(strLinkCriteria, 17, 1) = "0"
  Else
   Mid(strLinkCriteria, 17, 1) = "1"
  End If

' K: Lake basin selected
' *****************
  If (IsNull(rstMyRecordset.Fields(13).Value)) Then
   Mid(strLinkCriteria, 18, 1) = "0"
  ElseIf rstMyRecordset.Fields(13).Value = False Then
   Mid(strLinkCriteria, 18, 1) = "0"
  Else
   Mid(strLinkCriteria, 18, 1) = "1"
  End If

' L: Lake basin definition
' *****************
 If (IsNull(rstMyRecordset.Fields(14).Value)) Then
   Mid(strLinkCriteria, 19, 1) = "0"
  ElseIf rstMyRecordset.Fields(14).Value = "" Or rstMyRecordset.Fields(14).Value = 0 Then
   Mid(strLinkCriteria, 19, 1) = "0"
  Else
   Mid(strLinkCriteria, 19, 1) = "1"
  End If
  
' M: Downstream Water-quality pairs
' *****************
  
   bTestQW = bCheckQWfn(lngInputAnalysisNumber, 2)
   If bTestQW = True Then
    Mid(strLinkCriteria, 20, 1) = "1"
   Else
    Mid(strLinkCriteria, 20, 1) = "0"
   End If
  
   
strLinkCriteria = strLinkCriteria & strAnalysisName

CleanUp:
' Clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
  
   'return status for copying
  strOutput = strLinkCriteria ' Pass status code
  ' open the analysis status form?
  If intOutputLocation = 1 Then DoCmd.OpenForm "frmAnalysisStatus", , , , , , strLinkCriteria
  
Exit Sub

Status_Err:
 intOutErr = intOutErr + 1
 If intOutErr < 2 Then
  MsgBox Err.Description
  Resume CleanUp:
 End If
 Exit Sub
End Sub

Public Sub GetGISGridLimits(lngProject As Long, intErr As Integer, _
dLatNorth As Double, dlatSouth As Double, dLongWest As Double, dLongEast As Double, _
Optional lngMinRowNo As Long, Optional lngMaxRowNo As Long, _
Optional lngMinColNo As Long, Optional lngMaxColNo As Long, _
Optional lngGridCellNumber As Long, _
Optional dDeltaLat As Double, Optional dDeltaLong As Double)
'
' Purpose:
' To get the maximum and minimum lat/long values for the GISGrid
' associated with a project
'
' Arguments for the GIS Grid
' lngProject As Long input project number
' intErr As Integer output error condition 0=ok, 1 = no values 2 = no difference in max/min 3 other error
' dLatNorth As Double output maximum latitude
' dlatSouth As Double output minimum latitude
' dLongWest As Double output minimum Longitude
' dLongEast As Double output maximum Longitude
' lngMinRowNo As Long minimum grid row ID number (Optional)
' lngMaxRowNo As Long maximum grid row ID number (Optional)
' lngMinColNo As Long minimum grid column ID number (Optional)
' lngMaxColNo As Long maximum grid column ID number (Optional)
' dDeltaLat as Double latitude grid size (Optional)
' dDeltaLong As Double Longitude grid size (Optional)
' lngGridCellNumber As Long number of GIS grid cells (Optional)
'
' History:
' Version 1.0 July 07 2008 by Gregory E. Granato
'
' Arguments:
Dim strSQL As String                    ' Query text
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim dTestLatDifference As Double           ' test max/min difference
Dim dTestLongDifference As Double           ' test max/min difference
Dim dTestLatmax As Double
Dim dTestLatmin As Double
Dim dTestLongmax As Double
Dim dTestLongmin As Double
Dim dTestLat As Double
Dim dTestLong As Double

On Error GoTo GetGISGridLimits_Err:
' Initialize
  intErr = 0
  dLatNorth = 90#   ' North Pole
  dlatSouth = -90#  ' South Pole
  dLongWest = -180# ' Date line western Hemisphere
  dLongEast = 180#  ' Date line eastern Hemisphere
  
  
' set query string
 strSQL = "SELECT tblProject.Project_ID, Max(tblGISGrid.dTopLatitude) AS MaxOfdTopLatitude, " & _
 "Min(tblGISGrid.dBottomLatitude) AS MinOfdBottomLatitude, " & _
 "Max(tblGISGrid.dRightLongitude) AS MaxOfdRightLongitude, " & _
 "Min(tblGISGrid.dLeftLongitude) AS MinOfdLeftLongitude, " & _
 "Min(tblGISGrid.lGridCellRow) AS MinOflGridCellRow, Max(tblGISGrid.lGridCellRow) AS MaxOflGridCellRow, " & _
 "Min(tblGISGrid.lGridCellColumn) AS MinOflGridCellCol, Max(tblGISGrid.lGridCellColumn) AS MaxOflGridCellCol, " & _
 "Avg(Abs(tblGISGrid!dTopLatitude-tblGISGrid!dBottomLatitude)) AS deltaLat, " & _
 "Avg(Abs(tblGISGrid!dLeftLongitude-tblGISGrid!dRightLongitude)) AS deltaLong, " & _
 "Count(tblGISGrid.GISGridCell_ID) AS CountOfGISGridCell_ID " & _
 "FROM tblProject INNER JOIN tblGISGrid ON tblProject.GISGridSystem_ID = tblGISGrid.GISGridSystem_ID " & _
 "GROUP BY tblProject.Project_ID " & _
 "HAVING (((tblProject.Project_ID)=" & lngProject & ")); "

'Reference an ADO Recordset
 Set rstMyRecordset = New ADODB.Recordset
 
'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
 
' Are there values?
If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There are no records
 intErr = 1
 Exit Sub
End If
' **********************
' Manditory variables
' Are there differences
 dTestLatmax = rstMyRecordset.Fields("MaxOfdTopLatitude").Value
 dTestLatmin = rstMyRecordset.Fields("MinOfdBottomLatitude").Value
 dTestLongmax = rstMyRecordset.Fields("MaxOfdRightLongitude").Value
 dTestLongmin = rstMyRecordset.Fields("MinOfdLeftLongitude").Value
 dTestLat = Abs(dTestLatmax - dTestLatmin)
 dTestLong = Abs(dTestLongmax - dTestLongmin)
 
 ' Assign variables
 If (dTestLat = 0) Or (dTestLong = 0) Then intErr = 2
 
 If dTestLat <> 0 Then
  dLatNorth = dTestLatmax   ' good value
  dlatSouth = dTestLatmin  ' good value
 End If
 
 If dTestLong <> 0 Then
  dLongWest = dTestLongmin   ' good value
  dLongEast = dTestLongmax  ' good value
 End If
' **********************
' Optional variables
' lngMinRowNo As Long minimum grid row ID number (Optional)
  lngMinRowNo = rstMyRecordset.Fields("MinOflGridCellRow").Value
' lngMaxRowNo As Long maximum grid row ID number (Optional)
  lngMaxRowNo = rstMyRecordset.Fields("MaxOflGridCellRow").Value
' lngMinColNo As Long minimum grid column ID number (Optional)
  lngMinColNo = rstMyRecordset.Fields("MinOflGridCellCol").Value
' lngMaxColNo As Long maximum grid column ID number (Optional)
  lngMaxColNo = rstMyRecordset.Fields("MaxOflGridCellCol").Value
' dDeltaLat as Double latitude grid size (Optional)
  dDeltaLat = rstMyRecordset.Fields("deltaLat").Value
' dDeltaLong As Double Longitude grid size (Optional)
  dDeltaLong = rstMyRecordset.Fields("deltaLong").Value
' lngGridCellNumber As Long number of GIS grid cells (Optional)
  lngGridCellNumber = rstMyRecordset.Fields("CountOfGISGridCell_ID").Value
 
' Clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory

Exit Sub

GetGISGridLimits_Err:
 intErr = 3
 Exit Sub
End Sub

Public Function fnIsGISGridOK(lngTmpGridNo As Long) As Boolean
'
' Purpose:
' To Ensure that the Grid ID is in table tdxGISGridSystem
' and has at least 4 grid cells in table tblGISGrid
' Arguments
' lngTmpGridNo Input GIS Grid ID
' History:
' Version 1.0 June 23 2008 by Gregory E. Granato
'
Dim intErr As Integer                   ' integer error code 0 is ok
Dim lngCountGridCells As Long           ' Grid cell count
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim strSQL As String                    ' Query text

On Error GoTo fnIsGISGridOK_Err:

' First check if GIS Grid ID is in the domain table tdxGISGridSystem

strSQL = "SELECT tdxGISGridSystem.GISGridSystem_ID " & _
"FROM tdxGISGridSystem " & _
"WHERE (((tdxGISGridSystem.GISGridSystem_ID)=" & lngTmpGridNo & "));"

Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
'Check for data if ok set default project number GIS Grid ID
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this GIS Grid ID
    fnIsGISGridOK = False
 Else
    fnIsGISGridOK = True
 End If
 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 
 If fnIsGISGridOK = False Then Exit Function

' Second Check if GIS Grid ID is in the data table tblGISGrid and
' If there are one or more values

strSQL = "SELECT tblGISGrid.GISGridSystem_ID, Count(tblGISGrid.GISGridCell_ID) " & _
"AS CountOfGISGridCell_ID " & _
"FROM tblGISGrid " & _
"GROUP BY tblGISGrid.GISGridSystem_ID " & _
"HAVING (((tblGISGrid.GISGridSystem_ID)=" & lngTmpGridNo & "));"
Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
' Default value = bad
 fnIsGISGridOK = False
'Check for data if ok set default project number lngTmpGridNo
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this GIS Grid ID
    fnIsGISGridOK = False
 ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
   If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then fnIsGISGridOK = True ' There are sites for this project
 End If
 
 If rstMyRecordset.Fields(1).Value < 1 Then fnIsGISGridOK = False

 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 
Exit Function
 
fnIsGISGridOK_Err:
 fnIsGISGridOK = False
 Exit Function

End Function

Public Function fnIsEcoregionGroupOK(lngTmpGroupNo As Long) As Boolean
'
' Purpose:
' To Ensure that the EcoregionGroup ID is in table tdxEcoregionGroup
' and has more than one Ecoregion cell in table tblEcoregion
' Arguments
' lngTmpGroupNo Input EcoregionGroup ID
' History:
' Version 1.0 June 23 2008 by Gregory E. Granato
'
Dim intErr As Integer                   ' integer error code 0 is ok
Dim lngCountGroups As Long              ' Grid cell count
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim strSQL As String                    ' Query text

On Error GoTo fnIsEcoregionGroupOK_Err:

' First check if EcoregionGroup ID is in the domain table tdxEcoregionGroup

strSQL = "SELECT tdxEcoregionGroup.EcoregionGroup_ID " & _
"FROM tdxEcoregionGroup " & _
"WHERE (((tdxEcoregionGroup.EcoregionGroup_ID)=" & lngTmpGroupNo & "));"

Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
'Check for data if ok set default project number EcoregionGroup ID
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this EcoregionGroup ID
    fnIsEcoregionGroupOK = False
 Else
    fnIsEcoregionGroupOK = True
 End If
 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 
 If fnIsEcoregionGroupOK = False Then Exit Function

' Second Check if EcoregionGroup ID is in the data table tblGISGrid and
' If there are more than one value

strSQL = "SELECT tblEcoregion.EcoregionGroup_ID, Count(tblEcoregion.Ecoregion_ID) " & _
"AS CountOfEcoregion_ID " & _
"FROM tblEcoregion " & _
"GROUP BY tblEcoregion.EcoregionGroup_ID " & _
"HAVING (((tblEcoregion.EcoregionGroup_ID)=" & lngTmpGroupNo & "));"


Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
'Check for data if ok set default project number lngTmpGroupNo
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this EcoregionGroup
    fnIsEcoregionGroupOK = False
 Else
    If rstMyRecordset.Fields(1).Value < 2 Then
     fnIsEcoregionGroupOK = False
    Else
     fnIsEcoregionGroupOK = True
    End If
 End If
 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 

Exit Function
 
fnIsEcoregionGroupOK_Err:
 fnIsEcoregionGroupOK = False
 Exit Function

End Function

Public Function fnIsRainZoneGroupOK(lngTmpGroupNo As Long) As Boolean
'
' Purpose:
' To Ensure that the EcoregionGroup ID is in table tdxEcoregionGroup
' and has more than one Ecoregion cell in table tblEcoregion
' Arguments
' lngTmpGroupNo Input EcoregionGroup ID
' History:
' Version 1.0 June 23 2008 by Gregory E. Granato
'
Dim intErr As Integer                   ' integer error code 0 is ok
Dim lngCountGroups As Long              ' Grid cell count
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim strSQL As String                    ' Query text

On Error GoTo fnIsRainZoneGroupOK_Err:

' First check if RainZoneGroup is in the domain table tdxEcoregionGroup

strSQL = "SELECT tdxRainZoneGroup.RainZoneGroup_ID " & _
"FROM tdxRainZoneGroup " & _
"WHERE (((tdxRainZoneGroup.RainZoneGroup_ID)=" & lngTmpGroupNo & "));"

Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
'Check for data if ok set default project number RainZoneGroup
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this RainZoneGroup
    fnIsRainZoneGroupOK = False
 Else
    fnIsRainZoneGroupOK = True
 End If
 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 
 If fnIsRainZoneGroupOK = False Then Exit Function

' Second Check if RainZoneGroup_ID is in the data table tblRainzones and
' If there at least one value

strSQL = "SELECT tblRainZones.RainZoneGroup_ID, Count(tblRainZones.RainZone_ID) " & _
"AS CountOfRainZone_ID " & _
"FROM tblRainZones " & _
"GROUP BY tblRainZones.RainZoneGroup_ID " & _
"HAVING (((tblRainZones.RainZoneGroup_ID)=" & lngTmpGroupNo & "));"

Set rstMyRecordset = New ADODB.Recordset

'Populate Recordset
 rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
'Check for data if ok set default project number lngTmpGroupNo
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this EcoregionGroup
    fnIsRainZoneGroupOK = False
 Else
    If rstMyRecordset.Fields(1).Value < 1 Then
     fnIsRainZoneGroupOK = False
    Else
     fnIsRainZoneGroupOK = True
    End If
 End If
 'clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
 

Exit Function
 
fnIsRainZoneGroupOK_Err:
 fnIsRainZoneGroupOK = False
 Exit Function

End Function


Public Function lngGridCellsPerEcoregion(lngEcoregionGroup As Long, lngGridGroup As Long, _
lngEcoregionNumber As Long) As Long
'
' Purpose to provide the number of grid cells for a given ecoregion in a given ecoregion group
' and grid group
'
' lngEcoregionGroup User defined group of ecoregions in table tdxEcoregionGroup
'                   used in tblEcoregion default is USEPA Level III nutrient ecoregions and
'                   specified in project table
' lngGridGroup User defined grid system in table tdxGISGridSystem
'              used in table tblGISGrid default is conterminious US
'              specified in project table
' lngEcoregionNumber -- the user defined ecoregion number (not the database ID)
'
' History: Created July 10 2008 by Gregory E. Granato
'
' Arguments
Dim bHasdata As Boolean                 ' has data
Dim strSQL As String                    ' query string
Dim rstMyRecordset As ADODB.Recordset   ' recordset
Dim lngTempOutput As Long               ' temporary output

On Error GoTo lngGridCellsPerEcoregion_Err:
 
 strSQL = "SELECT Count(tblGISGrid.GISGridCell_ID) AS CountOfGISGridCell_ID " & _
 "FROM tblEcoregion INNER JOIN (tblGISGrid INNER JOIN tasGISGridEcoregion ON tblGISGrid.GISGridCell_ID = " & _
 "tasGISGridEcoregion.GISGridCell_ID) ON tblEcoregion.Ecoregion_ID = tasGISGridEcoregion.Ecoregion_ID " & _
 "WHERE (((tblEcoregion.lEcoregionNumber) <> " & lngEcoregionNumber & ")) " & _
 "GROUP BY tblGISGrid.GISGridSystem_ID, tblEcoregion.EcoregionGroup_ID " & _
 "HAVING (((tblGISGrid.GISGridSystem_ID)=" & lngGridGroup & ") AND " & _
 "((tblEcoregion.EcoregionGroup_ID)=" & lngEcoregionGroup & "));"
 

'Reference an ADO Recordset
 Set rstMyRecordset = New ADODB.Recordset
 
 'Populate Recordset
  rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
  
  ' Check values
  bHasdata = False
  If rstMyRecordset.BOF And rstMyRecordset.EOF Then
   bHasdata = False
  ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
   If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are sites for this project
  End If
   
   
 ' assign temporary value
 If bHasdata = True Then ' There is an ecoregion for this analysis
  lngTempOutput = rstMyRecordset.Fields(0).Value
 Else ' There is no ecoregion for this analysis
  lngTempOutput = -9999
 End If
      
 ' assign function value
   lngGridCellsPerEcoregion = lngTempOutput
      
 ' Clean up recordset
    If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
    Set rstMyRecordset = Nothing   'Free memory

 Exit Function

lngGridCellsPerEcoregion_Err:
 lngGridCellsPerEcoregion = -9999
 Exit Function

End Function

Public Function EcoName(lngEcoID As Long) As String
'
' Purpose:
' To get the ecoregion name
' lngEcoID As Long input ecoregion ID number and return it as a string
'
' History:
' Version 1.0 July 20 2008 by Gregory E. Granato
'
Dim strSQL As String                   ' Query String
Dim rstMyRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean                 ' test data


On Error GoTo EcoName_Err:
    
strSQL = "SELECT tblEcoregion.Ecoregion_ID, tblEcoregion.lEcoregionNumber, tblEcoregion.tEcoregionName " & _
"FROM tblEcoregion " & _
"WHERE (((tblEcoregion.Ecoregion_ID)=" & lngEcoID & "));"
    
   
 'Reference an ADO Recordset
  Set rstMyRecordset = New ADODB.Recordset

 'Populate Recordset
  rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockOptimistic
 
 ' Check values
 bHasdata = False
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There are no records
  bHasdata = False
 ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are station stats in an/the analysis
 End If
 
 If bHasdata = True Then
  EcoName = "Ecoregion: " & rstMyRecordset.Fields("lEcoregionNumber").Value & " " & _
  rstMyRecordset.Fields("tEcoregionName").Value
 Else
  EcoName = ""
 End If

 ' Clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory

Exit Function

EcoName_Err:
 EcoName = ""
 Exit Function
End Function
Public Function RainZoneName(lngRZID As Long) As String
'
' Purpose:
' To get the ecoregion name
' lngRzID As Long input rain zone ID number and return it as a string
'
' History:
' Version 1.0 July 20 2008 by Gregory E. Granato
'
Dim strSQL As String                   ' Query String
Dim rstMyRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean                ' test data
Dim strRzName As String                ' temp name
Dim strRzNumber As String              ' temp number

On Error GoTo EcoName_Err:
    
strSQL = "SELECT tblRainZones.RainZone_ID, tblRainZones.lRainZoneIndex, tblRainZones.tRainZoneName " & _
"FROM tblRainZones " & _
"WHERE (((tblRainZones.RainZone_ID)=" & lngRZID & "));"
     
 'Reference an ADO Recordset
  Set rstMyRecordset = New ADODB.Recordset

 'Populate Recordset
  rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockOptimistic
 
 ' Check values
 bHasdata = False
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There are no records
  bHasdata = False
 ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are station stats in an/the analysis
 End If
 
 RainZoneName = ""
 
 If bHasdata = True Then
  strRzNumber = Trim(rstMyRecordset.Fields("lRainZoneIndex").Value)
  strRzName = Trim(rstMyRecordset.Fields("tRainZoneName").Value)
  If Len(strRzNumber) > 0 Then
   If Len(strRzName) > 0 Then
    RainZoneName = "Rain Zone " & strRzNumber & ": " & strRzName
   Else
    RainZoneName = "Rain Zone: " & strRzNumber
   End If
  Else
   If Len(strRzName) > 0 Then RainZoneName = "Rain Zone: " & strRzName
  End If
 End If

 ' Clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory

Exit Function

EcoName_Err:
 RainZoneName = ""
 Exit Function
End Function

Sub CheckSTR(MyText As String, strVal As String, intP As Integer)
'
' Purpose to check to see if an input is a valid string and if so assign it, if not assign zero-length string
'
' History: Created Mar. 2005 by Gregory E. Granato
'
' Arguments
Dim intErr As Integer
Dim interr2 As Integer
'
intErr = IIf(IsNull(Trim(MyText)), 1, 0)    ' text box text is null intProblem = 1
  If intErr = 1 Then
   intP = intP + 1
   strVal = MyText
  ElseIf Trim(MyText) = "" Then
   intP = intP + 1 ' text box is empty intProblem = 1
   strVal = ""
  Else
   strVal = Trim(MyText)
  End If
End Sub

Sub CheckNRS(MyVal As Variant, sVal As Single, intP As Integer)
'
' Purpose to check to see if an input is a valid single and if so assign it, if not assign -999.000
'
' History: Created Mar. 2005 by Gregory E. Granato
'
' Arguments
Dim intErr As Integer
Dim interr2 As Integer
'
intErr = IIf(IsNull(Trim(MyVal)), 1, 0)    ' text box text is null intProblem = 1
  If intErr = 1 Then
   intP = intP + 1
   sVal = -9999#
  ElseIf Trim(MyVal) = "" Then
   intP = intP + 1 ' text box is empty intProblem = 1
   sVal = -9999#
  Else
   Call chkSingle(Trim(MyVal), sVal, interr2) ' check that input is a valid single precision number if so assign to 2nd argument.
   If interr2 <> 0 Then
    intP = intP + 1
    sVal = -9999#
   End If
  End If
End Sub
Sub CheckNRD(MyVal As Variant, dVal As Double, intP As Integer)
'
' Purpose to check to see if an input is a valid double and if so assign it, if not assign -999.000
'
' History: Created Mar. 2005 by Gregory E. Granato
'
' Arguments
Dim intErr As Integer
Dim interr2 As Integer
'
intErr = IIf(IsNull(Trim(MyVal)), 1, 0)    ' text box text is null intProblem = 1
  If intErr = 1 Then
   intP = intP + 1
   dVal = -9999#
  ElseIf Trim(MyVal) = "" Then
   intP = intP + 1 ' text box is empty intProblem = 1
   dVal = -9999#
  Else
   Call chkDouble(Trim(MyVal), dVal, interr2)  ' check that input is a valid double precision number if so assign to 2nd argument.
   If interr2 <> 0 Then
    intP = intP + 1
    dVal = -9999#
   End If
  End If
End Sub

Sub chkLong(instuff As Variant, lout As Long, intEC As Integer)
'
' Purpose:
' To check that a number is a long by assigning it. an error condition will indicate
' text
' History:
' Version 1.0 May 2004 by G.E. Granato
'
' strInStr  Input string
' error condition
' Arguments
  Dim dtest As Double ' test string for rounding
  Dim lTest As Long  'test input string
  ' if Error type mismatch (input is not a long number) assign intEC as 2
    On Error GoTo Err_NotANumber:
  ' initialize error code
    intEC = 0
  ' test for null and for conversion
    If IsNull(instuff) Then
     intEC = 3
     Exit Sub
    ElseIf Trim(instuff = "") Then
     intEC = 3
     Exit Sub
    Else
     dtest = instuff
     lTest = Round(dtest, 0)
    End If
    lout = CLng(lTest)
  Exit Sub
Err_NotANumber:
  intEC = 2
  Exit Sub
End Sub

Sub chkSingle(instuff As Variant, Sout As Single, intEC As Integer)
'
' Purpose:
' To check that a number is a single by assigning it. an error condition will indicate
' text
' History:
' Version 1.0 May 2004 by G.E. Granato
'
' strInStr  Input string
' error condition
' Arguments
  Dim sTest As Single  'test input string
  ' if Error type mismatch (input is not a Single precision number) assign intEC as 2
    On Error GoTo Err_NotANumber:
  ' initialize error code
    intEC = 0
  ' test for null and for conversion
    If IsNull(instuff) Then
     intEC = 3
     Exit Sub
    ElseIf Trim(instuff = "") Then
     intEC = 3
     Exit Sub
    Else
     sTest = instuff
    End If
    Sout = CSng(sTest)
  Exit Sub
Err_NotANumber:
  intEC = 2
  Exit Sub
End Sub

Sub chkDouble(instuff As Variant, dout As Double, intEC As Integer)
'
' Purpose:
' To check that a number is a single by assigning it. an error condition will indicate
' text
' History:
' Version 1.0 May 2004 by G.E. Granato
'
' strInStr  Input string
' error condition
' Arguments
  Dim dtest As Double  'test input string
  ' if Error type mismatch (input is not a Double precision number) assign intEC as 2
    On Error GoTo Err_NotANumber:
  ' initialize error code
    intEC = 0
  ' test for null and for conversion
    If IsNull(instuff) Then
     intEC = 3
     Exit Sub
    ElseIf Trim(instuff = "") Then
     intEC = 3
     Exit Sub
    Else
     dtest = instuff
    End If
    dout = CDbl(dtest)
  Exit Sub
Err_NotANumber:
  intEC = 2
  Exit Sub
End Sub

Public Sub MathString(MString As String, dMyInAverage As Double, dMyInSD As Double, _
dTmpSkew As Double, lngTransform As Long)
'
' Purpose to convert user input to other statistics
'
' History: Created September 2008 by Gregory E. Granato
'
' MString As String output math string
' dMyInAverage As Double input average
' dMyInSD As Double input standard deviation
' dTmpSkew as double input skew coefficient
' lngTransform as long input transform Transform 1: Untransformed 2:Log10 3:LN
'
' Confidence interval of skew Kirby
' LN-Arithmetic Chow
' Arguments
Dim strMStr As String
Dim dTmpAvg As Double  'Temporary (retransformed) Average
Dim dTmpSD As Double   'Temporary (retransformed) Standard Deviation
Dim dTmpCOVL As Double
Dim dTmpCOVA As Double
Dim dMyGeoMean As Double
Dim sSolveForN As Double
Dim lngSampleCount
Dim strSkewText As String

On Error GoTo MathString_Err:

MString = ""

strMStr = strMStr & "Statistical Summary of Input Values: " & vbCrLf

If lngTransform = 1 Then ' arithmetic values
 strMStr = " Arithmetic statistics:" & vbCrLf & vbCrLf
 strMStr = strMStr & "Mean: " & dMyInAverage & vbCrLf
 strMStr = strMStr & "Standard Deviation: " & dMyInSD & vbCrLf
 
 If dMyInAverage <> 0 Then
  dTmpCOVA = dMyInSD / dMyInAverage
  strMStr = strMStr & "Coefficient of Variation (COV): " & dTmpCOVA & vbCrLf
 Else
  strMStr = strMStr & "Error arithmetic water-quality variables should not have a mean of zero!" & vbCrLf
 End If
 
 strMStr = strMStr & "Skew Coefficient: " & dTmpSkew & vbCrLf
 
ElseIf lngTransform = 2 Then
' Log Base 10
 strMStr = "Approximate conversion of mean and standard deviation in common-log units to equivalent arithmetic values." & vbCrLf
 strMStr = strMStr & "The conversion equations are based on the assumption of zero skew in log space." & vbCrLf & vbCrLf
 dMyGeoMean = 10# ^ (dMyInAverage)
 strMStr = strMStr & "Geometric Mean: " & dMyGeoMean & vbCrLf
 dTmpAvg = 10# ^ (dMyInAverage + (Log(10#) * ((dMyInSD * dMyInSD) / 2#)))
 dTmpSD = Sqr((dTmpAvg ^ 2#) * ((10# ^ (Log(10#) * (dMyInSD * dMyInSD))) - 1#))
 strMStr = strMStr & "Mean: " & dTmpAvg & vbCrLf
 strMStr = strMStr & "Standard Deviation: " & dTmpSD & vbCrLf
 If dTmpAvg <> 0# Then
  dTmpCOVA = dTmpSD / dTmpAvg
  strMStr = strMStr & "Coefficient of Variation (COV): " & dTmpCOVA & vbCrLf
 End If
 
Else
 ' natural Log
 strMStr = "Approximate conversion of mean and standard deviation in natural-log units to equivalent arithmetic values." & vbCrLf
 strMStr = strMStr & "The conversion equations are based on the assumption of zero skew in log space." & vbCrLf & vbCrLf
 dMyGeoMean = Exp(dMyInAverage)
 strMStr = strMStr & "Geometric Mean: " & dMyGeoMean & vbCrLf
 dTmpAvg = Exp((dMyInAverage + ((dMyInSD * dMyInSD) / 2#)))
 strMStr = strMStr & "Mean: " & dTmpAvg & vbCrLf
 dTmpSD = Sqr((dTmpAvg ^ 2#) * (Exp(dMyInSD * dMyInSD) - 1#))
 strMStr = strMStr & "Standard Deviation: " & dTmpSD & vbCrLf
 If dTmpAvg <> 0# Then
  dTmpCOVA = dTmpSD / dTmpAvg
  strMStr = strMStr & "Coefficient of Variation (COV): " & dTmpCOVA & vbCrLf
 End If
End If

'If Abs(dTmpSkew) <= 0.1 Then
' lngSampleCount = 2300
'Else
' lngSampleCount = CLng((6# / ((Abs(dTmpSkew) / 1.96) ^ 2)))
'End If
'
'If lngTransform = 1 Then
'  strSkewText = "The coefficient of skew is within the 95 percent confidence limit " & vbCrLf & _
'  "of a normal distribution for sample sizes less than about " & lngSampleCount & " measurements."
'Else
'  strSkewText = "The coefficient of skew is within the 95 percent confidence limit " & vbCrLf & _
'  "of a lognormal distribution for sample sizes less than about " & lngSampleCount & " measurements."
'End If

'strMStr = strMStr & strSkewText


MString = strMStr

Exit Sub

MathString_Err:

MString = "Error in input statistics."

Exit Sub

End Sub

Public Sub LaunchHelp(lngHelpNumber As Long)
'
' Purpose:
' To Launch frmExplanation with text explaining the contents of the calling form
' History:
' Version 1.0 26 October 2008 by Gregory E. Granato
'
Dim strFormName As String       ' Target form name
Dim strLinkCriteria As String   ' Link criteria to control form-load events
Dim strOpenArgs As String   ' Link criteria to control form-load events

On Error GoTo Err_LaunchHelp

' Set parameters and open form
   strFormName = "frmExplanation"      ' target form name
   strLinkCriteria = lngHelpNumber ' Link crieria Value of lngExplanation_ID in table tblExplanationMemo
   strOpenArgs = lngHelpNumber
   DoCmd.OpenForm strFormName, , , , , , strOpenArgs

Exit_LaunchHelp:
    Exit Sub

' Handle errors
Err_LaunchHelp:
    MsgBox Err.Description
    Resume Exit_LaunchHelp
End Sub

Public Sub ExitSELDM()
'
' Purpose:
' To exit the database (after confirming)
' History:
' Version 1.0 June 20 2008 by Gregory E. Granato
' Version 1.1 09/02/2011 by Gregory E. Granato provides output table cleaning on exit from anywhere
'
Dim intMsgBox As Integer                ' Message box return value
Dim strMsgBox As String                ' Message String


On Error GoTo Err_ExitSELDM:

strMsgBox = "This button will close the user interface and" & vbCrLf & _
 "the Microsoft Access database." & vbCrLf & vbCrLf & _
 "Do you want to exit the SELDM database application?"

 ' Make sure the user really wants to quit
    intMsgBox = MsgBox(strMsgBox, vbYesNo, "Exit SELDM?")
    If intMsgBox = 6 Then ' Yes Quit
     ' Do we need to clear output tables?
     If modPublicInterface.bCheckQWOutTable = True Then
      Call modPublicInterface.DoMyStatusBar("Emptying output tables")
      Call modMainSELDM.RerunEmpty 'Empty output tables
      Call modPublicInterface.DoMyStatusBar("Done")
     End If
      DoCmd.Quit
    Else
     Exit Sub
    End If
    
Exit_ExitSELDM:
    Exit Sub

Err_ExitSELDM:
    MsgBox Err.Description
    Resume Exit_ExitSELDM
End Sub

Public Function strPCode(lngMyQWID As Long, intReturn As Integer) As String
'
' Purpose:
' To return water-quality parameter strings
' History:
' Version 1.0 Nov 27 2008 by Gregory E. Granato
'
' lngMyQWID Water-quality ID
' intReturn what do we return:
' 0: Name only 1: Pcode only 2: Group only
' 3: Pcode_Name 4: Pcode_Group_Name

Dim bHasdata As Boolean                 ' test data
Dim rstPcodeRecordset As ADODB.Recordset   ' recordset
Dim strMainSQL As String                ' Query text
Dim strMyPcode As String
Dim strMyPGroup As String
Dim strMyPName As String

On Error GoTo strPCode_Err:

'Reference an ADO Recordset
  Set rstPcodeRecordset = New ADODB.Recordset

strMainSQL = "SELECT tdsUSEPAParameterCodes.Parameter_ID, " & _
"tdsUSEPAParameterCodes.tPcode, tdsUSEPAParameterCodes.tParameterGroup, tdsUSEPAParameterCodes.tParameterName " & _
"FROM tdsUSEPAParameterCodes " & _
"WHERE (((tdsUSEPAParameterCodes.Parameter_ID)=" & lngMyQWID & "));"

'Populate Recordset
 rstPcodeRecordset.Open strMainSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
 
' Check values
 bHasdata = False
 If rstPcodeRecordset.BOF And rstPcodeRecordset.EOF Then  ' There is no data for this project
  bHasdata = False
 ElseIf IsNull(rstPcodeRecordset.Fields(1).Value) = False Then
  If IsEmpty(rstPcodeRecordset.Fields(1).Value) = False Then bHasdata = True ' There is pcode info
 End If
 
 If bHasdata = True Then
  strMyPName = rstPcodeRecordset.Fields("tParameterName").Value
  strMyPcode = rstPcodeRecordset.Fields("tPcode").Value
  strMyPGroup = rstPcodeRecordset.Fields("tParameterGroup").Value
  
  If intReturn = 0 Then
   strPCode = strMyPName
  ElseIf intReturn = 1 Then
   strPCode = strMyPcode
  ElseIf intReturn = 2 Then
   strPCode = strMyPGroup
  ElseIf intReturn = 3 Then
   strPCode = strMyPcode & " " & strMyPName
  Else
   strPCode = strMyPcode & " " & strMyPGroup & " " & strMyPName
  End If
  
 Else
  strPCode = "Undefined"
 End If

 ' Clean up recordset
  If rstPcodeRecordset.State = adStateOpen Then rstPcodeRecordset.Close  'IF Recordset is open, close it
  Set rstPcodeRecordset = Nothing   'Free memory

Exit Function

strPCode_Err:
 strPCode = "Undefined"
Exit Function
 
End Function

Public Function strMyTransformation(lngMyInTransformation As Long) As String
'
' Purpose:
' To return transformation parameter strings
' History:
' Version 1.0 Nov 27 2008 by Gregory E. Granato
'
' lngMyInTransformation Transformation ID
Dim bHasdata As Boolean                 ' test data
Dim rstTransformRecordset As ADODB.Recordset   ' recordset
Dim strMainSQL As String                ' Query text

On Error GoTo strMyTransformation_Err:

'Reference an ADO Recordset
  Set rstTransformRecordset = New ADODB.Recordset
  
strMainSQL = "SELECT tdsTransformation.Transformation_ID, tdsTransformation.tTansformation " & _
"FROM tdsTransformation " & _
"WHERE (((tdsTransformation.Transformation_ID)=" & lngMyInTransformation & "));"

'Populate Recordset
 rstTransformRecordset.Open strMainSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
 
' Check values
 bHasdata = False
 If rstTransformRecordset.BOF And rstTransformRecordset.EOF Then  ' There is no data for this project
  bHasdata = False
 ElseIf IsNull(rstTransformRecordset.Fields(1).Value) = False Then
  If IsEmpty(rstTransformRecordset.Fields(1).Value) = False Then bHasdata = True ' There are station stats in an/the analysis
 End If
 
 If bHasdata = True Then
  strMyTransformation = rstTransformRecordset.Fields(1).Value
 Else
  strMyTransformation = "Undefined"
 End If

 ' Clean up recordset
  If rstTransformRecordset.State = adStateOpen Then rstTransformRecordset.Close  'IF Recordset is open, close it
  Set rstTransformRecordset = Nothing   'Free memory

Exit Function

strMyTransformation_Err:
 strMyTransformation = "Undefined"
Exit Function
 
End Function

Public Function fnbGoodQWID(lngMyInA As Long, lngMyInQWID As Long) As Boolean
'
' Purpose to check the highway runoff/upstream water quality definition ID.
'
' History: Created Dec 05 2008 by Gregory E. Granato
' lngMyInA as long 1: Highway QW 2: Background QW
' lngMyInQWID water quality ID in respective table
'
Dim bHasdata As Boolean                 ' test data
Dim rstMyRecordsetQWID As ADODB.Recordset    ' recordset
Dim strSQL As String                ' Query text
Dim intOutErr As Integer

On Error GoTo fnbGoodQWID_Err:
intOutErr = 0

If lngMyInA = 1 Then ' Highway QW
strSQL = "SELECT tblQWHighway.HighwayWaterQuality_ID " & _
"FROM tblQWHighway " & _
"WHERE (((tblQWHighway.HighwayWaterQuality_ID)=" & lngMyInQWID & "));"

ElseIf lngMyInA = 2 Then ' Background QW
strSQL = "SELECT tblQWUpstream.UpstreamWaterQuality_ID " & _
"FROM tblQWUpstream " & _
"WHERE (((tblQWUpstream.UpstreamWaterQuality_ID)=" & lngMyInQWID & "));"

Else 'Error
 fnbGoodQWID = False
 Exit Function
End If

'Reference an ADO Recordset
  Set rstMyRecordsetQWID = New ADODB.Recordset

'Populate Recordset
 rstMyRecordsetQWID.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

' Check values
 bHasdata = False
 If rstMyRecordsetQWID.BOF And rstMyRecordsetQWID.EOF Then  ' There is no record
  bHasdata = False
 ElseIf IsNull(rstMyRecordsetQWID.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordsetQWID.Fields(0).Value) = False Then bHasdata = True ' There are data
 End If

 fnbGoodQWID = bHasdata

CleanUp:
   If rstMyRecordsetQWID.State = adStateOpen Then rstMyRecordsetQWID.Close  'IF Recordset is open, close it
   Set rstMyRecordsetQWID = Nothing   'Free memory

Exit Function

fnbGoodQWID_Err:
 fnbGoodQWID = False
 intOutErr = intOutErr + 1
 If intOutErr < 2 Then GoTo CleanUp:
 Exit Function
End Function
Public Function fnbGoodQWPairID(lngMyInQWID As Long) As Boolean
'
' Purpose to check the water-quality-pair definition ID.
'
' History: Created Dec 30 2008 by Gregory E. Granato
' lngMyInA as long 1: Highway QW 2: Background QW
' lngMyInQWID water quality ID in respective table
'
Dim bHasdata As Boolean                 ' test data
Dim rstMyRecordsetQWID As ADODB.Recordset    ' recordset
Dim strSQL As String                ' Query text
Dim intOutErr As Integer

On Error GoTo fnbGoodQWPairID_Err:
intOutErr = 0

strSQL = "SELECT tblQWDownstream.DownstreamWaterQuality_ID " & _
"FROM tblQWDownstream " & _
"WHERE (((tblQWDownstream.DownstreamWaterQuality_ID)=" & lngMyInQWID & "));"


'Reference an ADO Recordset
  Set rstMyRecordsetQWID = New ADODB.Recordset

'Populate Recordset
 rstMyRecordsetQWID.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

' Check values
 bHasdata = False
 If rstMyRecordsetQWID.BOF And rstMyRecordsetQWID.EOF Then  ' There is no record
  bHasdata = False
 ElseIf IsNull(rstMyRecordsetQWID.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordsetQWID.Fields(0).Value) = False Then bHasdata = True ' There are data
 End If

 fnbGoodQWPairID = bHasdata

CleanUp:
   If rstMyRecordsetQWID.State = adStateOpen Then rstMyRecordsetQWID.Close  'IF Recordset is open, close it
   Set rstMyRecordsetQWID = Nothing   'Free memory
Exit Function

Exit Function

fnbGoodQWPairID_Err:
 fnbGoodQWPairID = False
 intOutErr = intOutErr + 1
 If intOutErr < 2 Then GoTo CleanUp:
 Exit Function
End Function

Public Sub TrapezoidStats(dMin As Double, dlB As Double, dub As Double, dMax As Double, _
dAvg As Double, dSD As Double)
'
' Purpose:
' To calculate the average and standard deviation of the triangular/trapeziodal distribution
' History:
' Version 1.0 Oct 25 2008 by Gregory E. Granato
'
' Reference:
' Kacker, R.N., and Lawrence, J.F., 2007, Trapezoid and triangular distributions for Type B evaluation of
' standard uncertainty: Metrologia, v. 44, p. 117-127.
'
' Arguments
' dMin minimum trapezoidal value (lower bound) input
' dlB  lower bound of the most probable value input
' dub  upper bound of the most probable value input
' dMax maximum trapezoidal value (upper bound) input
' dAvg calculated average of the trapezoidal distribution given input variables output
' dSD  calculated standard deviation of the trapezoidal distribution given input variables output
Dim intMsgBox As Integer
Dim intWhere As Integer
Dim dH As Double
Dim dR As Double
Dim ds As Double
Dim dt As Double
Dim dMyMean As Double
Dim dMyVar As Double

On Error GoTo TrapezoidStats_Err:
intWhere = 0
dR = dlB - dMin ' lower segment length
ds = dub - dlB  ' middle segment length
dt = dMax - dub ' upper segment length
dH = 2# / ((dMax - dMin) + (dub - dlB))

dMyMean = ((dMax ^ 2#) - (dMin ^ 2#)) + ((dub ^ 2#) - (dlB ^ 2#)) - (dMin * dlB) + (dub * dMax)
dMyMean = dMyMean / (3 * ((dMax - dMin) + (dub - dlB)))

intWhere = 1 ' Calculated Avg

dMyVar = 3 * ((dR + 2 * ds + dt) ^ 4#) + 6# * (dR ^ 2# + dt ^ 2#) * ((dR + 2# * ds + dt) ^ 2#) - ((dR ^ 2# - dt ^ 2#) ^ 2#)
dMyVar = dMyVar / ((12# * (dR + 2# * ds + dt)) ^ 2#)

intWhere = 2 ' Calculated Variance

dAvg = dMyMean

dSD = Sqr(dMyVar)

Exit Sub
TrapezoidStats_Err:
 If intWhere < 1 Then dAvg = -9999#
 If intWhere <= 1 Then
  dSD = -9999#
 ElseIf intWhere = 2 Then
  dSD = Sqr(Abs(dMyVar))
 End If
 
Exit Sub
End Sub


Public Function dTrapezoidInverseCDF(dMin As Double, dlB As Double, dub As Double, dMax As Double, _
dPercentile) As Double
'
' Purpose:
' To calculate the sample value for a given percentile with a triangular/trapeziodal distribution
' History:
' Version 1.0 Oct 25 2008 by Gregory E. Granato
'
' Reference:
' Kacker, R.N., and Lawrence, J.F., 2007, Trapezoid and triangular distributions for Type B evaluation of
' standard uncertainty: Metrologia, v. 44, p. 117-127.
'
' Arguments
' dMin minimum trapezoidal value (lower bound)
' dlB  lower bound of the most probable value
' dub  upper bound of the most probable value
' dMax maximum trapezoidal value (upper bound)
' dPercentile input percentile for which to calculate the inverse CDF
Dim dH As Double ' height of the trapezoidal distribution

On Error GoTo dTrapezoidInverseCDF_Err:

dH = 2# / ((dMax - dMin) + (dub - dlB))

' Get median

 If ((dH / 2#) * (dlB - dMin)) >= dPercentile Then
  dTrapezoidInverseCDF = dMin + Sqr((2# * (dlB - dMin)) / dH) * Sqr(dPercentile)
 ElseIf (1 - ((dH / 2#) * (dMax - dub))) >= dPercentile Then
  dTrapezoidInverseCDF = ((dMin + dlB) / 2#) + (dPercentile / dH)
 Else
  dTrapezoidInverseCDF = dMax - (Sqr((2# * (dMax - dub)) / dH) * Sqr(1# - dPercentile))
 End If

Exit Function
dTrapezoidInverseCDF_Err:
 dTrapezoidInverseCDF = -9999#
Exit Function
End Function

Public Function bLakeAnalysisfn(lngInAnalysisID As Long) As Boolean
'
' Purpose:
' To determine if an analysis includes a lake-basin analysis
' History:
' Version 1.0 Dec 30 2008 by Gregory E. Granato
'
' Arguments
Dim strSQL As String
Dim rstMyRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean
Dim intOutErr As Integer

On Error GoTo bLakeAnalysisfn_Err:
intOutErr = 0

'Reference an ADO Recordset
  Set rstMyRecordset = New ADODB.Recordset

strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblHighwayAnalysis.bLakeBasinAnalysis " & _
"FROM tblHighwayAnalysis " & _
"WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngInAnalysisID & "));"

rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

' Check values
 bHasdata = False
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There is no data for this analysis
  bHasdata = False
 ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis
 End If
 
 If bHasdata = False Then
  bLakeAnalysisfn = False
 Else
  bLakeAnalysisfn = CBool(Nz(rstMyRecordset.Fields(1).Value, 0))
 End If

CleanUp:
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory
  
 Exit Function
 
bLakeAnalysisfn_Err:
 bLakeAnalysisfn = False
  intOutErr = intOutErr + 1
 If intOutErr < 2 Then Resume CleanUp:
 Exit Function
End Function

Public Function bCheckQWfn(lngInAnalysisID As Long, intQWCategory As Integer) As Boolean
'
' Purpose:
' To determine if an analysis includes one or more water-quality definitions
'
' lngInAnalysisID As Long  Analysis ID
' intQWCategory as integer Type of water-quality variable 0: Highway, 1: Upstream 2: Downstream
'
' History:
' Version 1.0 Jan 07 2009 by Gregory E. Granato
'
' Arguments
Dim strSQL As String
Dim rstMyQWRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean
Dim intOutErr As Integer

On Error GoTo bCheckQWfn_Err:
intOutErr = 0

'Reference an ADO Recordset
  Set rstMyQWRecordset = New ADODB.Recordset
  
If intQWCategory = 0 Then   '0: Highway

 strSQL = "SELECT tasAnalysisHighwayQW.HighwayAnalysis_ID " & _
 "FROM tasAnalysisHighwayQW " & _
 "WHERE (((tasAnalysisHighwayQW.HighwayAnalysis_ID)=" & lngInAnalysisID & "));"

ElseIf intQWCategory = 1 Then ' 1: Upstream

 strSQL = "SELECT tasAnalysisUpstreamQW.HighwayAnalysis_ID " & _
 "FROM tasAnalysisUpstreamQW " & _
 "WHERE (((tasAnalysisUpstreamQW.HighwayAnalysis_ID)=" & lngInAnalysisID & "));"

Else '2: Downstream

 strSQL = "SELECT tasAnalysisDownstreamQW.HighwayAnalysis_ID " & _
 "FROM tasAnalysisDownstreamQW " & _
 "WHERE (((tasAnalysisDownstreamQW.HighwayAnalysis_ID)=" & lngInAnalysisID & "));"

End If
  
rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

' Check values
 bHasdata = False
 If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then  ' There is no data for this analysis
  bHasdata = False
 ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis
 End If
  
 bCheckQWfn = bHasdata
 
CleanUp:
  If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close  'IF Recordset is open, close it
  Set rstMyQWRecordset = Nothing   'Free memory
  
 Exit Function
 
bCheckQWfn_Err:
 bCheckQWfn = False
  intOutErr = intOutErr + 1
 If intOutErr < 2 Then Resume CleanUp:
 Exit Function
End Function

Public Sub UpdateProgressBar(strInputForm As String, _
strProgressBarName As String, lngMaxLenProgress As Long, _
lngStepNumber As Long, lngNumberofSteps As Long, _
strStatusBoxName As String, strStatus As String, lngMaxLenStatus As Long)
'
' Purpose:
' To update the progress bar and/or status text if defined
' strInputForm As String input form name
' strProgressBarName As String the name of the ProgressBar (for progress dots) text box
' lngMaxLenProgress As Long maximum number of characters in strProgress
' lngStepNumber As Long current step
' lngNumberofSteps As Long, total number of steps
' strStatusBoxName As String the name of the Status text box
' strStatus As String the strStatus text
' lngMaxLenStatus As Long maximum number of characters in strStatus
' History:
' Version 1.0 Jan 16 2009 by Gregory E. Granato
'
' Arguments
Dim frmRunAnalysis As Form
Dim ctlProgressBar As Control
Dim ctlStatusText As Control
Dim dProportion As Double
Dim lngI As Long
Dim lngJ As Long
Dim strProgress As String

On Error GoTo UpdateProgressBar_Err:

If modPublicInterface.fnbIsFormLoaded(strInputForm) = False Then 'If it is not open an error will occur
 Exit Sub
End If

 strProgressBarName = Nz(strProgressBarName, "")
 strStatusBoxName = Nz(strStatusBoxName, "")
 strStatus = Nz(strStatus, "")

 DoCmd.Hourglass False
  
  dProportion = (lngStepNumber / lngNumberofSteps)
  lngJ = CLng(dProportion * lngMaxLenProgress)
  If lngJ > lngMaxLenProgress Then lngJ = lngMaxLenProgress
  
  For lngI = 1 To lngJ
   strProgress = strProgress & Chr(149)  ' update progress bar within form
  Next lngI
  
  Forms.Item(strInputForm).Controls.Item(strProgressBarName).Value = strProgress
  
  If Len(strStatusBoxName) > 0 Then
   If Len(strStatus) <= lngMaxLenProgress Then
    ' Assign to form
    Forms.Item(strInputForm).Controls.Item(strStatusBoxName).Value = strStatus
   Else
    Forms.Item(strInputForm).Controls.Item(strStatusBoxName).Value = Left(strStatus, lngMaxLenProgress)
   End If
  End If
  
 Forms.Item(strInputForm).Repaint
 
 DoCmd.Hourglass True
  
Exit Sub
UpdateProgressBar_Err:
 Exit Sub
End Sub

Public Function fnbIsFormLoaded(strMyCurrentForm As String) As Boolean
'
' Purpose:
' To see if a form is open
' strMyCurrentForm As String input form name
' History:
' Version 1.0 Jan 16 2009 by Gregory E. Granato
'
' Arguments
 Dim bAmILoaded As Boolean
' Dim strmsgstr As String

On Error GoTo fnbIsFormLoaded_Err:

bAmILoaded = Application.CurrentProject.AllForms(strMyCurrentForm).IsLoaded


'If bAmILoaded = True Then
' strmsgstr = "Error: Form " & strMyCurrentForm & " is already loaded." & vbCrLf & _
' "The SELDM user interface must be used one form at a time." & vbCrLf & _
' "Please use the previously open version of this form."
 
' MsgBox strmsgstr, vbCritical, "Duplicate Form Load Error:"
'End If

 fnbIsFormLoaded = bAmILoaded
 
 Exit Function
 
fnbIsFormLoaded_Err:
 MsgBox Err.Description
 fnbIsFormLoaded = False
 Exit Function
End Function

Public Function fnbIsSeedIDinTable(lngSeedID As Long) As Boolean
'
' Purpose:
' To Ensure that an input seed number is in the seed table
'
' Arguments
' lngSeedID the input seed ID
'
' History:
' Version 1.0 June 23 2008 by Gregory E. Granato
'
Dim rstMySeedRecordset As ADODB.Recordset   ' recordset
Dim strSQL As String                        ' Query text
Dim intErr As Integer                       ' problem flag
Dim bHasdata As Boolean                     ' test data

On Error GoTo fnbIsSeedIDinTable_Err:
intErr = 0


' Reference an ADO Recordset
  Set rstMySeedRecordset = New ADODB.Recordset

strSQL = "SELECT tblURNSeeds.URNSeed_ID " & _
"FROM tblURNSeeds " & _
"WHERE (((tblURNSeeds.URNSeed_ID)=" & lngSeedID & "));"

'Populate Recordset
 rstMySeedRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
 
' Check values
 bHasdata = False
 If rstMySeedRecordset.BOF And rstMySeedRecordset.EOF Then  ' There is no data for this analysis
  bHasdata = False
 ElseIf IsNull(rstMySeedRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMySeedRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis
 End If

fnbIsSeedIDinTable = bHasdata

CleanUp:
  If rstMySeedRecordset.State = adStateOpen Then rstMySeedRecordset.Close  'IF Recordset is open, close it
  Set rstMySeedRecordset = Nothing   'Free memory
  
 Exit Function
 
fnbIsSeedIDinTable_Err:
  fnbIsSeedIDinTable = False
  intErr = intErr + 1
  If intErr < 2 Then GoTo CleanUp:
  Exit Function
 End Function
 
Public Function fnGetMyVersion(inttoggle As Integer) As String
' Purpose to get the latest version number and date
'
' inttoggle = input number indicating what is wanted
'
' History: Created March 2009 by Gregory E. Granato
'
' Arguments
Dim rstMyRecordset As ADODB.Recordset
Dim strSQL As String
Dim strBuild01 As String
Dim strBuild02 As String
Dim bHasdata As Boolean

On Error GoTo Version_Err:

If inttoggle = 0 Or inttoggle = 1 Then ' version number and date

strSQL = "SELECT tblVersionInformation.strVersionNumber, " & _
"tblVersionInformation.strVersionDate, Max(tblVersionInformation.Version_ID) AS MaxOfVersion_ID " & _
"FROM tblVersionInformation " & _
"GROUP BY tblVersionInformation.strVersionNumber, tblVersionInformation.strVersionDate " & _
"ORDER BY Max(tblVersionInformation.Version_ID) DESC;"

ElseIf inttoggle = 999 Then ' All version numbers, dates, citations, and explanations

strSQL = "SELECT tblVersionInformation.Version_ID, " & _
"tblVersionInformation.strVersionNumber, tblVersionInformation.strVersionDate, " & _
"tblVersionInformation.mVersionCitation, tblVersionInformation.mVersionExplanation " & _
"FROM tblVersionInformation " & _
"ORDER BY tblVersionInformation.Version_ID;"

Else ' Last (most current) version number, date, citation, and explanation

strSQL = "SELECT Last(tblVersionInformation.Version_ID) AS LastOfVersion_ID, " & _
"Last(tblVersionInformation.strVersionNumber) AS LastOfstrVersionNumber, " & _
"Last(tblVersionInformation.strVersionDate) AS LastOfstrVersionDate, " & _
"Last(tblVersionInformation.mVersionCitation) AS LastOfmVersionCitation, " & _
"Last(tblVersionInformation.mVersionExplanation) AS LastOfmVersionExplanation, " & _
"Max(tblVersionInformation.Version_ID) AS MaxOfVersion_ID " & _
"FROM tblVersionInformation;"

End If

' Reference an ADO Recordset
  Set rstMyRecordset = New ADODB.Recordset
 
' Open existing Record set
  rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly
 
' Check values
  bHasdata = False
  If rstMyRecordset.BOF And rstMyRecordset.EOF Then
   bHasdata = False
  ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
   If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are sites for this project
  End If
     
 ' assign temporary value
 If bHasdata = True Then '
  If inttoggle = 0 Or inttoggle = 1 Then ' 0: Just get version number 1: Get version number & date
   strBuild01 = "Version: " & rstMyRecordset.Fields(0).Value
   strBuild02 = Nz(rstMyRecordset.Fields(1).Value, "")
  ElseIf inttoggle = 999 Then  ' Catalog whole explanation
   strBuild01 = "Please Note: Database versions are listed in chronological order. " & _
   "Use the scroll bar to view information that extends beyond the end of the text box. " & _
   vbCrLf & vbCrLf
   ' Get records
   rstMyRecordset.MoveFirst
   Do While rstMyRecordset.EOF = False
    strBuild01 = strBuild01 & _
    "Version: " & Nz(rstMyRecordset.Fields(1).Value, "") & vbCrLf & _
    Nz(rstMyRecordset.Fields(2).Value, "") & vbCrLf & _
    Nz(rstMyRecordset.Fields(3).Value, "") & vbCrLf & _
    Nz(rstMyRecordset.Fields(4).Value, "") & vbCrLf & _
    vbCrLf & "******* Please Note *******" & vbCrLf
    rstMyRecordset.MoveNext
   Loop
   
   strBuild02 = vbCrLf & _
   "The version number has three numbers separated by decimal points and, " & _
   "potentially, a trailing alphanumeric character (for example 1.0.0.a).  " & _
   "From left to right the numbers designate major revisions, minor revisions, and bug fixes. " & _
   "The alphanumeric character(s) designate versions with additional datasets. " & _
   "Each of the components may have multiple digits (for example Version 1.1.10.zz)."
   
  Else  ' Get last version information
   strBuild01 = "Version: " & Nz(rstMyRecordset.Fields(1).Value, "")
   strBuild02 = vbCrLf & Nz(rstMyRecordset.Fields(2).Value, "") & vbCrLf & _
                Nz(rstMyRecordset.Fields(3).Value, "") & vbCrLf & _
                Nz(rstMyRecordset.Fields(4).Value, "") & vbCrLf
  End If
 Else ' There is no version Information
  strBuild01 = "Version 1.0.0"
  strBuild02 = "September 2011"
 End If

  If inttoggle <> 0 Then
   fnGetMyVersion = strBuild01 & " " & strBuild02
  Else
   fnGetMyVersion = strBuild01
  End If
 
 ' Clean up recordset
   If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
   Set rstMyRecordset = Nothing   'Free memory
 
 Exit Function
Version_Err:
 fnGetMyVersion = "Version 1.0.0"
 Exit Function
End Function

Public Function strExplanation(lngExplanationNumber As Long) As String
'
' Purpose:
' To get the information from tblExplanationMemo based on the explanation number (lngExplanation_ID)
'
' History:
' Version 1.0 Nov 19 2008 by Gregory E. Granato
'
Dim strSQL As String                    ' Query text
Dim rstExplanationRecordset As ADODB.Recordset  ' recordset
Dim intOutErr As Integer

On Error GoTo Function_Err:  ' exit gracefully if there is an error
intOutErr = 0

' set query string to get form parameters
strSQL = "SELECT tblExplanationMemo.lngExplanation_ID, tblExplanationMemo.mExplanation " & _
"FROM tblExplanationMemo " & _
"WHERE (((tblExplanationMemo.lngExplanation_ID)=" & lngExplanationNumber & "));"

'Reference the ADO Recordset
 Set rstExplanationRecordset = New ADODB.Recordset
 
'Populate Recordset
  rstExplanationRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

strExplanation = rstExplanationRecordset.Fields("mExplanation").Value
  
CleanUpRecordSet:   ' clear recordset free memory
 If rstExplanationRecordset.State = adStateOpen Then rstExplanationRecordset.Close  'IF Recordset is open, close it
 Set rstExplanationRecordset = Nothing   'Free memory
 
 Exit Function
Function_Err:
  strExplanation = "Error: record number " & lngExplanationNumber & _
  " in table tblExplanationMemo is not properly specified."
  intOutErr = intOutErr + 1
  If intOutErr < 2 Then GoTo CleanUpRecordSet:
  
 Exit Function
 
 End Function

Public Function fnGetRegionID(intWhatRegion As Integer, lngMyInputProject As Long, dMyInputLong As Double, dMyInputLat As Double) As Long
'
' Purpose:
' To see if there is a rain zone (0) or ecoregion (1) and return the rain zone number (or -9999 if not)
' Using project number and location
'
' intWhatRegion  0 = Rain Zone 1 = ecoregion
' lngMyInputProject project of interest
' dMyInputLat input latitude
' dMyInputLong input longitude
'
' History:
' Version 1.0 Aug 5 2008 by Gregory E. Granato
' Version 2.0 Aug 2010 By Gregory E. Granato generalized to rainzone or ecoregion changed from GetRainZoneID to fnGetRegionID
'
Dim strSQL As String                   ' Query String
Dim rstMyRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean                ' test data


On Error GoTo fnGetRegionID_Err:

If intWhatRegion = 0 Then
 strSQL = "SELECT tblRainZones.RainZone_ID " & _
 "FROM tblGISGrid INNER JOIN (((tdxRainZoneGroup INNER JOIN tblProject ON " & _
 "tdxRainZoneGroup.RainZoneGroup_ID = tblProject.RainZoneGroup_ID) INNER JOIN tblRainZones ON " & _
 "tdxRainZoneGroup.RainZoneGroup_ID = tblRainZones.RainZoneGroup_ID) INNER JOIN tasGISGridRainZone ON " & _
 "tblRainZones.RainZone_ID = tasGISGridRainZone.RainZone_ID) ON " & _
 "tblGISGrid.GISGridCell_ID = tasGISGridRainZone.GISGridCell_ID " & _
 "WHERE (((tblProject.Project_ID)=" & lngMyInputProject & ") AND " & _
 "((tblGISGrid.dLeftLongitude)<=" & dMyInputLong & ") AND " & _
 "((tblGISGrid.dRightLongitude)>" & dMyInputLong & ") AND " & _
 "((tblGISGrid.dTopLatitude)>" & dMyInputLat & ") AND " & _
 "((tblGISGrid.dBottomLatitude)<=" & dMyInputLat & "));"

Else
 strSQL = "SELECT tblEcoregion.Ecoregion_ID " & _
 "FROM (tdxEcoregionGroup INNER JOIN (tblEcoregion INNER JOIN " & _
 "(tblGISGrid INNER JOIN tasGISGridEcoregion ON tblGISGrid.GISGridCell_ID = tasGISGridEcoregion.GISGridCell_ID) ON " & _
 "tblEcoregion.Ecoregion_ID = tasGISGridEcoregion.Ecoregion_ID) ON " & _
 "tdxEcoregionGroup.EcoregionGroup_ID = tblEcoregion.EcoregionGroup_ID) INNER JOIN " & _
 "tblProject ON tdxEcoregionGroup.EcoregionGroup_ID = tblProject.EcoregionGroup_ID " & _
 "WHERE (((tblProject.Project_ID)=" & lngMyInputProject & ") AND " & _
 "((tblGISGrid.dLeftLongitude)<=" & dMyInputLong & ") AND " & _
 "((tblGISGrid.dRightLongitude)>" & dMyInputLong & ") AND " & _
 "((tblGISGrid.dTopLatitude)>" & dMyInputLat & ") AND " & _
 "((tblGISGrid.dBottomLatitude)<=" & dMyInputLat & "));"

End If
   
 'Reference an ADO Recordset
  Set rstMyRecordset = New ADODB.Recordset

 'Populate Recordset
  rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockOptimistic
 
 ' Check values
 bHasdata = False
 If rstMyRecordset.BOF And rstMyRecordset.EOF Then  ' There are no records
  bHasdata = False
 ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are station stats in an/the analysis
 End If
 
 If bHasdata = True Then
  fnGetRegionID = rstMyRecordset.Fields(0).Value
 Else
  fnGetRegionID = -9999
 End If

 ' Clean up recordset
  If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close  'IF Recordset is open, close it
  Set rstMyRecordset = Nothing   'Free memory

Exit Function

fnGetRegionID_Err:
fnGetRegionID = -9999
 Exit Function
 
End Function
Public Function bCheckQWOutTable() As Boolean
'
' Purpose:
' To determine if an analysis has been run and output tables are full
'
' History:
' Version 1.0 Sept 2 2011 by Gregory E. Granato
'
' Arguments
Dim strSQL As String
Dim rstMyQWRecordset As ADODB.Recordset  ' recordset
Dim bHasdata As Boolean
Dim intOutErr As Integer
Dim lngCount As Long

On Error GoTo bCheckQWOutTable_Err:
intOutErr = 0

'Reference an ADO Recordset
  Set rstMyQWRecordset = New ADODB.Recordset
  


 strSQL = "SELECT Count(tblOutputStormEvent.lngStormNumber) AS CountOflngStormNumber " & _
          "FROM tblOutputStormEvent;"

rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly

' Check values
 bHasdata = False
 If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then  ' There is no data for this analysis
  bHasdata = False
 ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then
  If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis
 End If
  
 If bHasdata Then
  bCheckQWOutTable = bHasdata
 Else
  lngCount = rstMyQWRecordset.Fields(0).Value
  If lngCount = 0 Then
   bCheckQWOutTable = False
  Else
   bCheckQWOutTable = True
  End If
 End If
  
CleanUp:
  If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close  'IF Recordset is open, close it
  Set rstMyQWRecordset = Nothing   'Free memory
  
 Exit Function
 
bCheckQWOutTable_Err:
 bCheckQWOutTable = False
  intOutErr = intOutErr + 1
 If intOutErr < 2 Then Resume CleanUp:
 Exit Function
End Function
Public Sub DoMyStatusBar(InText As String)
'
' Purpose to send a message to the access status bar
'
' Version 1.0 09/02/2011 by Gregory Granato
'
Dim varDoIt As Variant

On Error GoTo DoMyStatusBar_Err:

varDoIt = SysCmd(acSysCmdSetStatus, InText)

DoMyStatusBar_Err:
Exit Sub
End Sub

Public Function fnCheckMyBeta(intWhat As Integer) As Boolean
'
' Purpose to check the Beta-test status
'
' History: Created April 29 2009 by Gregory E. Granato
'          Updated for SELDM with new selections July 19, 2012 by GEG
'
' IntWhat 0 = Don't check 1 = Invisible 2 = short,
'         3 = long, and 4 = interactive
' Arguments
Dim strMsgBox As String                 ' MessageBox string
Dim intMsgBox As Integer
Dim strMyAnalysisType As String
Dim dtMyDate As Date

fnCheckMyBeta = False

'************Note: 2099*********** change if update
' ******** This is the drop dead date for this version *******
dtMyDate = CDate("02/12/2099 23:59")
' ******** This is the drop dead date for this version *******

Select Case intWhat

Case 0
 fnCheckMyBeta = True 'OK
 Exit Function

Case 1
 If dtMyDate >= Now() Then
  fnCheckMyBeta = True 'OK
  Exit Function
 Else
  fnCheckMyBeta = False ' Not OK DoCmd.Quit
  Exit Function
 End If

Case 2
 If dtMyDate >= Now() Then
  fnCheckMyBeta = True 'OK
  Exit Function
 Else
  strMsgBox = "This Beta-Test Version has expired!!!" & vbCrLf
  MsgBox strMsgBox, vbCritical, "Beta Test Expiration Notice:"
  fnCheckMyBeta = False ' Not OK DoCmd.Quit
  Exit Function
 End If

Case 3

 strMsgBox = "This is the SELDM Beta-Test File version ** 4.5.0 **" & vbCrLf & _
             "To ensure that multiple, incomplete-versions of SELDM do not remain in circulation" & vbCrLf & _
             "an expiration date of " & dtMyDate & " has been set." & vbCrLf & _
             "To get the most up-to-date version please visit the web site" & vbCrLf & _
             "  http://ma.water.usgs.gov/fhwa/SELDM.htm" & vbCrLf
             
 If dtMyDate >= Now() Then
  MsgBox strMsgBox, vbInformation, "Beta Test Notice:"
  fnCheckMyBeta = True 'OK
 Else
  strMsgBox = strMsgBox & vbCrLf & "This Beta-Test Version has expired!!!"
  MsgBox strMsgBox, vbCritical, "Beta Test Expiration Notice:"
  fnCheckMyBeta = False ' Not OK DoCmd.Quit
 End If
 
Case 4 ' Interactive
 
  strMsgBox = "This is the SELDM Beta-Test File version ** 4.5.0 **" & vbCrLf & _
              " 10/22/2012" & vbCrLf & _
              "Do not use this software unless you are a certified SELDM Beta Tester." & vbCrLf & _
              "To ensure that multiple, incomplete-versions of SELDM do not remain in circulation" & vbCrLf & _
              "an expiration date of " & dtMyDate & " has been set." & vbCrLf & _
              "To get the most up-to-date version please visit the web site" & vbCrLf & _
              "  http://ma.water.usgs.gov/fhwa/SELDM.htm" & vbCrLf
 
  If dtMyDate < Now() Then
   strMsgBox = strMsgBox & vbCrLf & "This Beta-Test Version has expired!!!" & vbCrLf
   MsgBox strMsgBox, vbCritical, "Beta Test Expiration Notice:"
   fnCheckMyBeta = False ' Not OK DoCmd.Quit
  Else
   strMsgBox = strMsgBox & vbCrLf & vbCrLf & "I certify that I am an approved Beta Tester." & vbCrLf
   intMsgBox = MsgBox(strMsgBox, vbYesNo, "Beta Test Notice:")
   If intMsgBox = 6 Then
    fnCheckMyBeta = True 'OK
   Else
    fnCheckMyBeta = False ' Not OK DoCmd.Quit
   End If
 End If
End Select

Exit Function
End Function