?
Solved

Authentication Failed

Posted on 2003-03-11
8
Medium Priority
?
329 Views
Last Modified: 2012-06-27
I am using Access 2000 as a frontend with SQL Server 2000 serving as the back-end.


I have a form with VBA code.  The form opens and displays data without an issue, but when I try to execute an event procedure (it writes data to a table) I receive an 'Authentication Failed' error.

Why would the form display data from the SQL back-end, but not be able to execute some VBA code?

I can provide the code behind the form if necessary.

I have also made sure that the permissions are correct and able to write to the database.
0
Comment
Question by:mangerp
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 5
  • 3
8 Comments
 
LVL 3

Expert Comment

by:dfarthing
ID: 8128187
yes please post you code, I would have said sql databse permissions but if it's not that then it must be in your code.
0
 

Author Comment

by:mangerp
ID: 8128768
Option Compare Database
Option Explicit
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim TESTSqdf As DAO.QueryDef
Dim varItem As Variant
Dim strCriteria As String
Dim strSQL As String
Dim TESTSvarItem As Variant
Dim TESTSstrCriteria As String
Dim TESTSstrSQL As String

Dim rsLR As ADODB.Recordset
Dim rsTest As Recordset
Dim cn
Dim Species As String
Dim OEDetailDirty As Boolean

Private Sub CLINICNAME_AfterUpdate()
  Me.DOCTORNUM = DLookup("[DOCTORID]", "DOCTORS", "[CLINICID]='" & Me.CLINICNUM & "'")
End Sub

Private Sub Form_AfterUpdate()
  If OEDetailDirty Then
    DoCmd.Hourglass True
    If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
    OEMakeLabResults Me.AccessionNumber
    OEDetailDirty = False
    DoCmd.Hourglass False
  End If
  Me.AllowAdditions = False
End Sub

Private Sub CLINICNUM_AfterUpdate()
  Me.DOCTORNUM = DLookup("[DOCTORID]", "DOCTORS", "[CLINICID]='" & Me.CLINICNUM & "'")
End Sub

Private Sub CLINICNUM_NotInList(NewData As String, Response As Integer)
  Dim C As String
   
  C = Nz(DLookup("[ClinicAvscID]", "CLINICS", "([CLINICID]='" & NewData & "') and ([Active]=True)"), "")
  If C <> "" Then
    Me.CLINICNUM.Text = C
    Me.DOCTORNUM = DLookup("[DOCTORID]", "DOCTORS", "[CLINICID]='" & Me.CLINICNUM & "'")
    Response = False
  End If
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    End If
  End If
  If Not Me.NewRecord Then
    Me.ModifiedBy = Form_Switchboard.txtUser
    Me.ModificationDateTime = Now()
  End If
End Sub

Private Sub Form_Close()
  rsTest.Close
  Me.Refresh
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      DoCmd.Hourglass True
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
      DoCmd.Hourglass False
    End If
  End If
End Sub

Private Sub Form_Current()
  If Not Me.NewRecord Then
  '  If Me.AccessionNumber <> Me.txtAccessionNumber Then Me.txtAccessionNumber = Me.AccessionNumber
    Me.AllowAdditions = False
  End If
  Me.AllowEdits = (Nz(Me![BilledFlag]) = 0)
  Me.AllowDeletions = (Nz(Me![BilledFlag]) = 0)
  Me.REQDETAIL_subform.Locked = (Nz(Me![BilledFlag]) <> 0)
  Me.REQDETAIL_subform.Form.AllowAdditions = (Nz(Me![BilledFlag]) = 0)
  Me.REQDETAIL_subform.Form.AllowDeletions = (Nz(Me![BilledFlag]) = 0)
  Me.REQDETAIL_subform.Form.AllowEdits = (Nz(Me![BilledFlag]) = 0)
  Me.cmdAddOn.Enabled = (Nz(Me![BilledFlag]) <> 0)
  'Me.LabResultTests_subform.Visible = Me.LabResultTests_subform.Form.Recordset.RecordCount > 0
  Me.txtAccessionNumber.BackColor = 8421631 - (32385) * (Nz(Me.txtAccessionNumber) = Nz(Me.AccessionNumber))
  Me.txtAccessionNumber.SetFocus
End Sub

Private Sub Form_Open(Cancel As Integer)
  DoCmd.Hourglass True
  Echo False
  DoCmd.SetWarnings False
  DoCmd.RunSQL "SELECT TESTS.* INTO tblTests FROM TESTS;"
  DoCmd.RunSQL "SELECT TestResultLines.* INTO tblTestResultLines FROM TestResultLines;"
  DoCmd.RunSQL "SELECT TESTCOMPONENTS.* INTO tblTESTCOMPONENTS FROM TESTCOMPONENTS;"
  DoCmd.RunSQL "SELECT TestSpeciesRange.* INTO tblTestSpeciesRange FROM TestSpeciesRange;"
  Set db = CurrentDb()
  Set rsTest = db.OpenRecordset("tblTests", dbOpenSnapshot, dbReadOnly, dbReadOnly)
  Me.Recordset.MoveLast
  DoCmd.SetWarnings True
  Echo True
  DoCmd.Hourglass False
End Sub

Private Sub SPECIESCODE_BeforeUpdate(Cancel As Integer)
  If Nz(Me.SPECIESCODE, "") = "" Then
    MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
    Cancel = True
  Else
    If Me.REQDETAIL_subform.Form.Recordset.RecordCount > 0 Then
      If Me.SPECIESCODE.OldValue <> Me.SPECIESCODE.Value Then OEDetailDirty = True
    End If
  End If
End Sub

Private Sub txtAccessionNumber_AfterUpdate()
On Error GoTo Err_txtAccessionNumber_AfterUpdate
  If Nz(Me.txtAccessionNumber, "") = "" Then
    Beep
    Exit Sub
  End If
  DoCmd.Hourglass True
  Echo False
  Me.txtAccessionNumber = "V" & Format(Val(Right$(Me.txtAccessionNumber, Len(Me.txtAccessionNumber))), "00000000")
  Me.Recordset.FindFirst "[ACCESSIONNUMBER]='" & Me.txtAccessionNumber & "'"
  If Me.AccessionNumber <> Me.txtAccessionNumber Then
    'search available numbers
    If IsNull(DLookup("[AccessionNumber]", "REQUISITIONHEADER", "[AccessionNumber]='" & Me.txtAccessionNumber & "'")) Then
      If IsNull(DLookup("[AccessionNumber]", "AccessionNumbers", "[AccessionNumber]='" & Me.txtAccessionNumber & "'")) Then
        MsgBox "Accession Number not found!", vbApplicationModal + vbExclamation, "Not Found"
        DoCmd.GoToRecord acDataForm, Me.name, acFirst
        Me.txtAccessionNumber = Me.AccessionNumber
      Else
        'detect out of sequence accession entered
        If CheckOutOfSequence Then
          Me.AllowAdditions = True
          Me.AccessionNumber.DefaultValue = "'" & Me.txtAccessionNumber & "'"
          DoCmd.GoToRecord acDataForm, Me.name, acNewRec
          Me.AccessionNumber = Me.txtAccessionNumber
        End If
      End If
    Else
      MsgBox "Error locating Accession Number!", vbApplicationModal + vbExclamation, "ERROR"
    End If
  End If
  Me.CLINICNUM.SetFocus
  Me.txtAccessionNumber.BackColor = 8421631 - (32385) * (Nz(Me.txtAccessionNumber) = Nz(Me.AccessionNumber))
  Echo True
  DoCmd.Hourglass False
  Exit Sub
 
Err_txtAccessionNumber_AfterUpdate:
    MsgBox Err.DESCRIPTION
    Me.txtAccessionNumber.BackColor = 8421631
    Echo True
    DoCmd.Hourglass False
End Sub

Private Sub cmdBuildLabResultRecords_Click()
On Error GoTo Err_cmdBuildLabResultRecords_Click

  If Nz(Me.SPECIESCODE, "") = "" Then
    MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
    Me.SPECIESCODE.SetFocus
  Else
    DoCmd.Hourglass True
    Echo False
    'Me.LabResultTests_subform.Visible = False
    Me.Refresh
    If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
    OEMakeLabResults Me.AccessionNumber
    OEDetailDirty = False
  End If
 
Exit_cmdBuildLabResultRecords_Click:
  'Me.LabResultTests_subform.Visible = True
  Me.Refresh
  Me.LabResultTests_subform.Requery
  Echo True
  DoCmd.Hourglass False
  Exit Sub

Err_cmdBuildLabResultRecords_Click:
  MsgBox Err.DESCRIPTION
  Resume Exit_cmdBuildLabResultRecords_Click
   
End Sub

Private Sub cmdNextAcc_Click()
On Error GoTo Err_cmdNextAcc_Click
  Dim Cancel As Boolean
 
  Cancel = False
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      Me.Refresh
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
    End If
  End If
  If Not Cancel Then
    Me.txtAccessionNumber = Format(Val(Right$(Me.AccessionNumber, Len(Me.AccessionNumber) - 1)) + 1, "00000000")
    txtAccessionNumber_AfterUpdate
  End If

Exit_cmdNextAcc_Click:
    Exit Sub

Err_cmdNextAcc_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_cmdNextAcc_Click
   
End Sub

Private Sub cmd1stNewAcc_Click()
On Error GoTo Err_cmd1stNewAcc_Click
  Dim Acc As String
  Dim Cancel As Boolean
 
  Cancel = False
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      Me.Refresh
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
    End If
  End If
  If Not Cancel Then
    DoCmd.Hourglass True
    Acc = Nz(DLookup("[FirstOfAccessionNumber]", "qry1stNewAccNum"))
    Me.txtAccessionNumber = Right$(Acc, Len(Acc) - 1)
    txtAccessionNumber_AfterUpdate
  End If

Exit_cmd1stNewAcc_Click:
  DoCmd.Hourglass False
  Exit Sub

Err_cmd1stNewAcc_Click:
  MsgBox Err.DESCRIPTION
  Resume Exit_cmd1stNewAcc_Click
   
End Sub

Private Function CheckOutOfSequence() As Boolean
  Dim Acc As String, Acc1 As String, stPrompt As String
 
  Acc = "V" & Format(Val(Right$(Me.txtAccessionNumber, Len(Me.txtAccessionNumber) - 1)) - 1, "00000000")
  If "" = Nz(DLookup("[ACCESSIONNUMBER]", "REQUISITIONHEADER", "[ACCESSIONNUMBER]='" & Acc & "'"), "") Then
    Acc = Nz(DLookup("[FirstOfAccessionNumber]", "qry1stNewAccNum"))
    stPrompt = "The accession #: " & Me.txtAccessionNumber & " you chose if out of sequence!" & vbCrLf
    stPrompt = stPrompt & "The 1st available accession # is: " & Acc & vbCrLf & vbCrLf
    stPrompt = stPrompt & "Use accession #: " & Me.txtAccessionNumber & " anyway?"
    CheckOutOfSequence = (vbYes = MsgBox(stPrompt, vbApplicationModal + vbQuestion + vbYesNo, "Out of Sequence"))
  Else
    CheckOutOfSequence = True
  End If
End Function

Public Sub SetOEDetailDirty()
  OEDetailDirty = True
  Me.DoNotHold = Not Me.DoNotHold
  Me.DoNotHold = Not Me.DoNotHold
End Sub

Private Sub cmdPreviousAccession_Click()
On Error GoTo Err_cmdPreviousAccession_Click
  Dim Cancel As Boolean
 
  Cancel = False
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      Me.Refresh
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
    End If
  End If
  If Not Cancel Then
    DoCmd.GoToRecord , , acPrevious
    Me.txtAccessionNumber = Me.AccessionNumber
  End If

Exit_cmdPreviousAccession_Click:
    Me.txtAccessionNumber.BackColor = 8421631 - (32385) * (Nz(Me.txtAccessionNumber) = Nz(Me.AccessionNumber))
    Exit Sub

Err_cmdPreviousAccession_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_cmdPreviousAccession_Click
   
End Sub

Private Sub cmdFirstRecord_Click()
On Error GoTo Err_cmdFirstRecord_Click
  Dim Cancel As Boolean
 
  Cancel = False
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      Me.Refresh
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
    End If
  End If
  If Not Cancel Then
    DoCmd.GoToRecord , , acFirst
    Me.txtAccessionNumber = Me.AccessionNumber
  End If

Exit_cmdFirstRecord_Click:
    Me.txtAccessionNumber.BackColor = 8421631 - (32385) * (Nz(Me.txtAccessionNumber) = Nz(Me.AccessionNumber))
    Exit Sub

Err_cmdFirstRecord_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_cmdFirstRecord_Click
   
End Sub

Private Sub cmdLastRecord_Click()
On Error GoTo Err_cmdLastRecord_Click
  Dim Cancel As Boolean
 
  Cancel = False
  If OEDetailDirty Then
    If Nz(Me.SPECIESCODE, "") = "" Then
      Cancel = True
      MsgBox "The species must be entered to set the test normal ranges!", vbApplicationModal + vbExclamation, "Species Missing"
      Me.SPECIESCODE.SetFocus
    Else
      Me.Refresh
      If DCount("[CountOfBottomTestID]", "qryOverlappingResultLines") <> 0 Then OEVerifyReqDetail Me.AccessionNumber
      OEMakeLabResults Me.AccessionNumber
      OEDetailDirty = False
    End If
  End If
  If Not Cancel Then
    DoCmd.GoToRecord , , acLast
    Me.txtAccessionNumber = Me.AccessionNumber
  End If
 
Exit_cmdLastRecord_Click:
    Me.txtAccessionNumber.BackColor = 8421631 - (32385) * (Nz(Me.txtAccessionNumber) = Nz(Me.AccessionNumber))
    Exit Sub

Err_cmdLastRecord_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_cmdLastRecord_Click
   
End Sub
   
Private Sub OEVerifyReqDetail(AccNum As String)
On Error GoTo Err_OEVerifyReqDetail
  Dim SQL As String
  Dim rs As ADODB.Recordset
 
  Set rs = New ADODB.Recordset
  SQL = "SELECT REQDETAIL.* FROM REQDETAIL WHERE (((REQDETAIL.ACCESSIONNUMBER)='" & AccNum & "'));"
  rs.Open SQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly, adCmdText
  If rs.RecordCount > 0 Then
    rs.MoveFirst
    While Not rs.EOF
      If Not OEVerifyReqDetailItem(rs![AccessionNumber], rs![TESTID], rs![TESTID], 1) Then
        rs.Requery
        rs.MoveFirst
      Else
        rs.MoveNext
      End If
    Wend
  End If
  Exit Sub
 
Err_OEVerifyReqDetail:
    MsgBox Err.DESCRIPTION
End Sub

Private Function OEVerifyReqDetailItem(AccNum As String, ByVal ID As String, ByVal Panel As String, ByVal Level As Integer) As Boolean
On Error GoTo Err_OEVerifyReqDetailItem
  Dim SQL As String
  Dim rs As ADODB.Recordset

  OEVerifyReqDetailItem = True
  ' if top level then >1 else >0
  If DCount("[RDTRXNUM]", "ReqDetail", "[ACCESSIONNUMBER]='" & AccNum & "' and [TESTID]='" & ID & "'") > -(Level = 1) Then
    ' found duplicate error
    MsgBox "The test '" & ID & "' from ordered item '" & Panel & "', is also ordered as a separate item!" & vbCr & "The separate item will be removed from this order.", vbApplicationModal + vbExclamation, "Duplicate Error"
    SQL = "Select REQDETAIL.* FROM REQDETAIL "
    SQL = SQL & "WHERE (((REQDETAIL.ACCESSIONNUMBER)='" & AccNum & "') AND ((REQDETAIL.TESTID)='" & ID & "'));"
    Set rs = New ADODB.Recordset
    rs.Open SQL, CurrentProject.Connection, adOpenDynamic, adLockPessimistic, adCmdText
TryAgain:
    rs.Delete
    OEVerifyReqDetailItem = False
  End If
  SQL = "SELECT tblTESTCOMPONENTS.CHILDTESTID, tblTESTCOMPONENTS.PARENTTESTID "
  SQL = SQL & "FROM tblTESTCOMPONENTS "
  SQL = SQL & "WHERE (((tblTESTCOMPONENTS.PARENTTESTID)='" & ID & "'));"
  Set rs = New ADODB.Recordset
  rs.Open SQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
  If rs.RecordCount > 0 Then
    rs.MoveFirst
    ' for each child
    While Not rs.EOF
      If Not OEVerifyReqDetailItem(AccNum, rs![CHILDTESTID], Panel, Level + 1) Then
        'MsgBox "Error: could not locate components for test " & RS![CHILDTESTID], vbApplicationModal + vbExclamation, "ERROR"
        OEVerifyReqDetailItem = False
        rs.MoveLast
      End If
      rs.MoveNext
    Wend
    rs.Close
  End If
 
Exit_OEVerifyReqDetailItem:
  Exit Function

Err_OEVerifyReqDetailItem:
  If Err.Number = -2147217887 Then OEVerifyReqDetailItem = False
  MsgBox Err.DESCRIPTION
  Resume Exit_OEVerifyReqDetailItem

End Function

Private Sub OEMakeLabResults(AccNum As String)
On Error GoTo Err_OEMakeLabResults
  Dim rs As ADODB.Recordset
  Dim SQL As String
 

  ' Manger Inc. adjusted code on 05.03.2002 to  NOT DELETE any results with COMMENTS
  ' remove old lab result lines
  SQL = "DELETE LABRESULTS.* FROM LABRESULTS "
  SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='');"
  DoCmd.SetWarnings False
  DoCmd.RunSQL SQL
  SQL = "DELETE LABRESULTS.* FROM LABRESULTS "
  SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='0') AND ((LABRESULTS.TESTID)='H25');"
 
 
  DoCmd.RunSQL SQL
  ' update normal ranges for resulted lab result lines
  SQL = "UPDATE (REQUISITIONHEADER INNER JOIN LABRESULTS ON REQUISITIONHEADER.ACCESSIONNUMBER = LABRESULTS.ACCESSIONNUMBER) "
  SQL = SQL & "INNER JOIN tblTestSpeciesRange ON LABRESULTS.TESTID = tblTestSpeciesRange.TestID "
  SQL = SQL & "SET LABRESULTS.NORMLOW = [tblTestSpeciesRange]![NORMLOW], LABRESULTS.NORMHIGH = [tblTestSpeciesRange]![NORMHIGH] "
  SQL = SQL & "WHERE (((REQUISITIONHEADER.ACCESSIONNUMBER)='" & AccNum & "') and ((tblTestSpeciesRange.Species)='" & Me.SPECIESCODE & "'));"
 DoCmd.RunSQL SQL
  DoCmd.SetWarnings True
  SQL = "SELECT REQDETAIL.* FROM REQDETAIL "
  SQL = SQL & "WHERE (((REQDETAIL.ACCESSIONNUMBER)='" & AccNum & "'));"
  Set rs = New ADODB.Recordset
  rs.Open SQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
  If rs.RecordCount > 0 Then
    Set cn = New ADODB.Connection
    With cn
     
      ' CHANGE CONNECTION STRING TO POINT DIRECTLY TO THE BACKEND TABLE NOT THE DB WITHT THE LINKED TABLES
      '.ConnectionString = theData
      ' CHANGES addes 01/13/2003

      'ConnectionString:="Provider=SQLOLEDB.1;" & _
     ' "Data Source=Wahoo;Initial Catalog=AVL;" & _
     ' "User ID=AVL;Password=AVL"
     
     .Provider = "Microsoft.Jet.OLEDB.4.0"
     .ConnectionString = theData
     
      .Open
    End With
    Set rsLR = New ADODB.Recordset
    With rsLR
      .ActiveConnection = cn
      .SOURCE = "LABRESULTS"
      .CursorLocation = adUseServer
      .CursorType = adOpenKeyset
      .LockType = adLockPessimistic
      .Open Options:=adCmdTableDirect
      .Index = "SeekKey"
    End With
    rs.MoveFirst
    Species = Nz(DLookup("[SPECIESCODE]", "REQUISITIONHEADER", "[ACCESSIONNUMBER]='" & AccNum & "'"))
    While Not rs.EOF
      If Not OEMakeLabResultRecord(AccNum, rs![TESTID]) Then
        MsgBox "An error occurred generating the lab result lines for test: " & rs![TESTID], vbApplicationModal + vbCritical
      End If
      rs.MoveNext
    Wend
    rsLR.Close
    cn.Close
 End If
 
Exit_OEMakeLabResults:
  Exit Sub

Err_OEMakeLabResults:
  MsgBox Err.DESCRIPTION
  Resume Exit_OEMakeLabResults
End Sub

Private Function OEMakeLabResultRecord(AccNum As String, ByVal ID As String)
On Error GoTo Err_OEMakeLabResultRecord
  Dim SQL As String
  Dim rs As ADODB.Recordset
  Dim X
  Dim LRKey(1)

  OEMakeLabResultRecord = True
  SQL = "SELECT tblTestResultLines.BottomTestID "
  SQL = SQL & "FROM tblTestResultLines "
  SQL = SQL & "WHERE (((tblTestResultLines.TopTestID)='" & ID & "'));"
  Set rs = New ADODB.Recordset
  rs.Open SQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
  If rs.RecordCount > 0 Then
    rs.MoveFirst
    'for each Test Result Line
    While Not rs.EOF
      LRKey(0) = AccNum
      LRKey(1) = rs![BottomTestID]
      rsLR.MoveFirst
      rsLR.Seek LRKey(), adSeekFirstEQ
      If rsLR.EOF Then
        rsLR.AddNew
        rsLR![AccessionNumber] = AccNum
        rsLR![TESTID] = rs![BottomTestID]
        rsLR![RESULTS] = ""
        If rs![BottomTestID] = "H25" Then rsLR![RESULTS] = "0"
        rsLR![COMMENTS] = ""
        rsTest.FindFirst "[TestID]='" & rs![BottomTestID] & "'"
        If Not (rsTest.NoMatch Or rsTest.EOF) Then
          'special range handling
          X = DLookup("[TESTCOMPONENTS.ReportSpecialRange]", "TESTCOMPONENTS", "[CHILDTESTID]='" & rs![BottomTestID] & "' and [PARENTTESTID]='" & ID & "'")
          'if test component ReportSpecialRange OR ( no component and test ReportSpecialRange )
          If Nz(X) Or (IsNull(X) And Nz(rsTest![ReportSpecialRange])) Then
            rsLR![SpecialRange1] = Nz(rsTest![SpecialRange1])
            rsLR![SpecialRange2] = Nz(rsTest![SpecialRange2])
            rsLR![SpecialRange3] = Nz(rsTest![SpecialRange3])
            rsLR![SpecialRange4] = Nz(rsTest![SpecialRange4])
            rsLR![SpecialRange5] = Nz(rsTest![SpecialRange5])
            rsLR![SpecialRange6] = Nz(rsTest![SpecialRange6])
            rsLR![SpecialRange7] = Nz(rsTest![SpecialRange7])
            rsLR![SpecialRange8] = Nz(rsTest![SpecialRange8])
          End If
          rsLR![UNITS] = Nz(rsTest![UNITS])
          'species result range
          rsLR![NORMLOW] = Nz(DLookup("[NORMLOW]", "tblTestSpeciesRange", "[TESTID]='" & rs![BottomTestID] & "' and [Species]='" & Species & "'"))
          rsLR![NORMHIGH] = Nz(DLookup("[NORMHIGH]", "tblTestSpeciesRange", "[TESTID]='" & rs![BottomTestID] & "' and [Species]='" & Species & "'"))
          'set profile
          rsLR![Profile] = ID
          rsLR.Update
        Else
          MsgBox "Test # " & rs![BottomTestID] & " not found", vbApplicationModal + vbExclamation, "Error"
          OEMakeLabResultRecord = False
        End If
      End If

      rs.MoveNext
    Wend
    rs.Close
  End If
 
Exit_OEMakeLabResultRecord:
    Exit Function

Err_OEMakeLabResultRecord:
    OEMakeLabResultRecord = False
    MsgBox Err.DESCRIPTION
    Resume Exit_OEMakeLabResultRecord
 
End Function

Private Sub cmdAddOn_Click()
On Error GoTo Err_cmdAddOn_Click
  Dim OriginalAcc As String
  Dim NewAcc As String
  Dim Clinic As String
  Dim rsRH As ADODB.Recordset
  Dim SQL As String
 
  OriginalAcc = Me.AccessionNumber
  NewAcc = InputBox("Please enter the new accession # for the add on test(s).", "Accession #")
  If Nz(NewAcc) = "" Then
    Beep
  Else
    If Left(NewAcc, 1) <> "V" Then
      NewAcc = "V" & Format(Val(Right$(NewAcc, Len(NewAcc))), "00000000")
    End If
    Clinic = Nz(DLookup("[CLINICNUM]", "REQUISITIONHEADER", "[ACCESSIONNUMBER]='" & NewAcc & "'"), "")
    If Clinic = "" Then
      Me.txtAccessionNumber = Right$(NewAcc, Len(NewAcc) - 1)
      txtAccessionNumber_AfterUpdate
      If Me.AccessionNumber = NewAcc Then
        SQL = "SELECT REQUISITIONHEADER.* FROM REQUISITIONHEADER "
        SQL = SQL & "WHERE (((REQUISITIONHEADER.ACCESSIONNUMBER)='" & OriginalAcc & "'));"
        Set rsRH = New ADODB.Recordset
        rsRH.Open SQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly, adCmdText
        If Not rsRH.EOF Then
          Me.OWNER = rsRH![OWNER]
          Me.PATIENT = rsRH![PATIENT]
          Me.PATIENTID = rsRH![PATIENTID]
          Me.SPECIESCODE = rsRH![SPECIESCODE]
          Me.AGE = rsRH![AGE]
          Me.GENDER = rsRH![GENDER]
          Me.CHARTNUM = rsRH![CHARTNUM]
          Me.COLLECTIONDATE = rsRH![COLLECTIONDATE]
          Me.COLLECTIONTIME = rsRH![COLLECTIONTIME]
          Me.RCPTDATE = rsRH![RCPTDATE]
          Me.RCPTTIME = rsRH![RCPTTIME]
          Me.CLINICNUM = rsRH![CLINICNUM]
          Me.DOCTORNUM = rsRH![DOCTORNUM]
          Me.STATUS = rsRH![STATUS]
          If Nz(rsRH![COMMENT1], "") = "" Then
            Me.COMMENT1 = "Add on test(s) for Acc#" & rsRH![AccessionNumber]
          Else
            Me.COMMENT1 = rsRH![COMMENT1] & " Add on test(s) for Acc#" & rsRH![AccessionNumber]
          End If
          Me.COMMENT2 = rsRH![COMMENT2]
          Me.BILLTYPE = rsRH![BILLTYPE]
        End If
      End If
    Else
      MsgBox "Accession #:" & NewAcc & " already assigned to Clinic #:" & Clinic, vbExclamation, "Accession Error"
    End If
  End If
 
Exit_cmdAddOn_Click:
    Exit Sub

Err_cmdAddOn_Click:
    MsgBox Err.DESCRIPTION
    Resume Exit_cmdAddOn_Click
   
End Sub
Option Compare Database

Global theData


Public Sub LinkTables()
On Error GoTo ErrLinkTables
  Dim dbname As String
  Dim dbloc As String
  Dim Path
  Dim AXfiles
  Dim tmppath
  Dim rsServerList As ADODB.Recordset
  Dim Retries As Integer
 
  DoCmd.Hourglass True
  dbname = "AVL.mdb"
  Retries = 0
  While Retries < 2
    Set rsServerList = New ADODB.Recordset
    rsServerList.Open "LocalLabServerList", CurrentProject.Connection, adOpenKeyset, adLockReadOnly, adCmdTable
    If rsServerList.RecordCount > 0 Then
      rsServerList.MoveFirst
      Do
        If rsServerList![Active] Then
          dbloc = rsServerList![ServerNetworkName]
          Exit Do
        End If
        rsServerList.MoveNext
      Loop While Not rsServerList.EOF
    End If
    If dbloc <> "" Then If Not TryLastServer(dbloc, dbname) Then dbloc = ""
    If dbloc = "" Then
      If rsServerList.RecordCount > 0 Then
        rsServerList.MoveFirst
        Do
          dbloc = rsServerList![ServerNetworkName]
          If Not TryServer(dbloc, dbname) Then dbloc = ""
          rsServerList.MoveNext
        Loop Until rsServerList.EOF Or dbloc <> ""
      End If
    End If
    rsServerList.Close
    If dbloc = "" Then
      DoCmd.SetWarnings False
      DoCmd.RunSQL "SELECT LabServerList.* INTO LocalLabServerList FROM LabServerList;"
      DoCmd.SetWarnings True
      Retries = Retries + 1
    Else
      Retries = 2
    End If
  Wend
  If dbloc = "" Then
    If TryMe(dbname) Then
      DoCmd.Hourglass False
      DoCmd.OpenForm "LabServerList", acNormal, , , acFormEdit, acDialog
      Quit
    Else
      dbloc = ""
    End If
  End If
okout:
  If dbloc <> "" Then
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT LabServerList.* INTO LocalLabServerList FROM LabServerList;"
    DoCmd.SetWarnings True
    DoCmd.Hourglass False
    Exit Sub
  End If
 
errorout:
    DoCmd.Hourglass False
    MsgBox "Data tables could not be linked. Please be sure to locate the correct data files and then try again."
    End
   
ErrLinkTables:
    MsgBox Err.DESCRIPTION
    Resume errorout
End Sub

Private Function TryServer(Server As String, File As String) As Boolean
On Error GoTo Err_Out
  Dim tdf As TableDef
  Dim db As Database
  Dim Path As String
 
  TryServer = False
  If Server = fOSMachineName() Then
    Path = "C:\Documents and Settings\Administrator\Desktop\AVLDATA\"
  Else
    Path = "\\" & Server & "\Documents and Settings\Administrator\Desktop\AVLDATA\"
  End If
  Set db = CurrentDb()
  Set tdf = db.TableDefs("LabServerList")
  tdf.Connect = ";DATABASE=" & Path & File
  tdf.RefreshLink
  If Nz(DLookup("[Active]", "LabServerList", "[ServerNetworkName]='" & Server & "'"), 0) Then
    For Each tdf In db.TableDefs
        If tdf.Connect <> "" Then
            If Not IsNull(File) Then
              If (tdf.Connect <> ";DATABASE=" & Path & File) Then
                tdf.Connect = ";DATABASE=" & Path & File
                tdf.RefreshLink
            End If
            End If
        End If
    Next tdf
    TryServer = True
    theData = Path & File
    Form_frmFaxReports.Server = Server
  End If

Err_Out:
  ' do nothing
End Function

Private Function TryLastServer(Server As String, File As String) As Boolean
On Error GoTo Err_Out
  Dim tdf As TableDef
  Dim db As Database
  Dim Path As String
 
  TryLastServer = False
  If Server = fOSMachineName() Then
    Path = "C:\Documents and Settings\Administrator\Desktop\AVLDATA\"
  Else
    Path = "\\" & Server & "\Documents and Settings\Administrator\Desktop\AVLDATA\"
  End If
  Set db = CurrentDb()
  Set tdf = db.TableDefs("LabServerList")
  tdf.Connect = ";DATABASE=" & Path & File
  tdf.RefreshLink
  If Nz(DLookup("[Active]", "LabServerList", "[ServerNetworkName]='" & Server & "'"), 0) Then
    TryLastServer = True
    theData = Path & File
    Form_frmFaxReports.Server = Server
  End If

Err_Out:
  ' do nothing
End Function

Private Function TryMe(File As String) As Boolean
On Error GoTo Err_Out
  Dim tdf As TableDef
  Dim db As Database
  Dim Path As String
 
  TryMe = False
  Path = "C:\Documents and Settings\Administrator\Desktop\AVLDATA\"
  Set db = CurrentDb()
  Set tdf = db.TableDefs("LabServerList")
  tdf.Connect = ";DATABASE=" & Path & File
  tdf.RefreshLink
  For Each tdf In db.TableDefs
      If tdf.Connect <> "" Then
          If Not IsNull(File) Then
            If (tdf.Connect <> ";DATABASE=" & Path & File) Then
              tdf.Connect = ";DATABASE=" & Path & File
              tdf.RefreshLink
          End If
          End If
      End If
  Next tdf
  TryMe = True
  theData = Path & File

Err_Out:
  ' do nothing
End Function

0
 

Author Comment

by:mangerp
ID: 8220761
I'll raise you 150
0
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 3

Expert Comment

by:dfarthing
ID: 8223529
Thats alot of code to check can you pin point where it fails?, the problem could be with the sql login itself to rule this out can to update data on the form? if not your either missing a primary key or the login the database is using does not have permission to write to the database.

post the event where the failure occurs and I'll check it.
0
 

Author Comment

by:mangerp
ID: 8224587
This is the code that causes the error.  I have checked and triple checked the permissions to the data.  It seems ok because other form in the databse work fine.  I have a feeling that it may be an issue with the way the SQL code is attempting to write to the database.  This front-end is currently in production and works fine with an Access Back-end.

Good Luck... I appreciate your help












Private Sub OEMakeLabResults(AccNum As String)
On Error GoTo Err_OEMakeLabResults
  Dim rs As ADODB.Recordset
  Dim SQL As String
 

  ' Manger Inc. adjusted code on 05.03.2002 to  NOT DELETE any results with COMMENTS
  ' remove old lab result lines
  SQL = "DELETE LABRESULTS.* FROM LABRESULTS "
  SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='');"
  DoCmd.SetWarnings False
  DoCmd.RunSQL SQL
  SQL = "DELETE LABRESULTS.* FROM LABRESULTS "
  SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='0') AND ((LABRESULTS.TESTID)='H25');"
 
 
  DoCmd.RunSQL SQL
  ' update normal ranges for resulted lab result lines
  SQL = "UPDATE (REQUISITIONHEADER INNER JOIN LABRESULTS ON REQUISITIONHEADER.ACCESSIONNUMBER = LABRESULTS.ACCESSIONNUMBER) "
  SQL = SQL & "INNER JOIN tblTestSpeciesRange ON LABRESULTS.TESTID = tblTestSpeciesRange.TestID "
  SQL = SQL & "SET LABRESULTS.NORMLOW = [tblTestSpeciesRange]![NORMLOW], LABRESULTS.NORMHIGH = [tblTestSpeciesRange]![NORMHIGH] "
  SQL = SQL & "WHERE (((REQUISITIONHEADER.ACCESSIONNUMBER)='" & AccNum & "') and ((tblTestSpeciesRange.Species)='" & Me.SPECIESCODE & "'));"
 DoCmd.RunSQL SQL
  DoCmd.SetWarnings True
  SQL = "SELECT REQDETAIL.* FROM REQDETAIL "
  SQL = SQL & "WHERE (((REQDETAIL.ACCESSIONNUMBER)='" & AccNum & "'));"
  Set rs = New ADODB.Recordset
  rs.Open SQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly, adCmdText
  If rs.RecordCount > 0 Then
    Set cn = New ADODB.Connection
    With cn
     
      ' CHANGE CONNECTION STRING TO POINT DIRECTLY TO THE BACKEND TABLE NOT THE DB WITHT THE LINKED TABLES
      '.ConnectionString = theData
      ' CHANGES addes 01/13/2003

      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .ConnectionString = theData
      .Open
     '.Provider = "Microsoft.Jet.OLEDB.4.0"
     '.ConnectionString = theData
     '.Open
     
     
    End With
    Set rsLR = New ADODB.Recordset
    With rsLR
      .ActiveConnection = cn
      .SOURCE = "LABRESULTS"
      .CursorLocation = adUseServer
      .CursorType = adOpenKeyset
      .LockType = adLockPessimistic
      .Open Options:=adCmdTableDirect
      .Index = "SeekKey"
    End With
    rs.MoveFirst
    Species = Nz(DLookup("[SPECIESCODE]", "REQUISITIONHEADER", "[ACCESSIONNUMBER]='" & AccNum & "'"))
    While Not rs.EOF
      If Not OEMakeLabResultRecord(AccNum, rs![TESTID]) Then
        MsgBox "An error occurred generating the lab result lines for test: " & rs![TESTID], vbApplicationModal + vbCritical
      End If
      rs.MoveNext
    Wend
 
    rsLR.Close
    cn.Close
 
End If

Exit_OEMakeLabResults:
  Exit Sub

Err_OEMakeLabResults:
  MsgBox Err.DESCRIPTION
  Resume Exit_OEMakeLabResults
   
End Sub
0
 
LVL 3

Accepted Solution

by:
dfarthing earned 750 total points
ID: 8225884
I recomend almost a complete rewrite of the code, ditch dao completly and rewrite using ADO.

The dynamic sql statements cause some problems when upgrading to sqlserver as there are slight sysntax differences between sqlserver sql and access sql for instance.

SQL = "DELETE LABRESULTS.* FROM LABRESULTS "
SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='');"

would be changed to:
SQL = "DELETE  FROM LABRESULTS "
SQL = SQL & "WHERE (((LABRESULTS.ACCESSIONNUMBER)='" & AccNum & "') AND (NZ([LABRESULTS].[RESULTS],''))='');"

when converting a large dao based access app with plenty of vba code expect a large job in converting it, the last one i did took over a month by the time i'd optomised it for sql server!

send me the database and $1000 and i'll do it for you lol

hope this helps a little, post an email address if you want some of the help documents I've built up on this subject.
0
 

Author Comment

by:mangerp
ID: 8226149
Here is my e-mail

pmanger@avlcweb.com

Please contact me becasue I don't have a month and maybe we can work something out....

THANK YOU
0
 

Author Comment

by:mangerp
ID: 8226249
Nice to get validation from someone who has gone through the same thing.
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

International Data Corporation (IDC) prognosticates that before the current the year gets over disbursing on IT framework products to be sent in cloud environs will be $37.1B.
Ever wondered why sometimes your SQL Server is slow or unresponsive with connections spiking up but by the time you go in, all is well? The following article will show you how to install and configure a SQL job that will send you email alerts includ…
Via a live example, show how to extract insert data into a SQL Server database table using the Import/Export option and Bulk Insert.
This videos aims to give the viewer a basic demonstration of how a user can query current session information by using the SYS_CONTEXT function

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

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

Join & Ask a Question