frmdoctorschedule.frm

This file came from Planet-Source-Code.com...the home millions of lines of source code You can view

Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
  Call Functions.EnableMenu
End Sub


Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'This will display the current record position for this recordset
  lblStatus.Caption = "Record: " & CStr(adoPrimaryRS.AbsolutePosition)
End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  'This is where you put validation code
  'This event gets called when the following actions occur
  Dim bCancel As Boolean

  Select Case adReason
  Case adRsnAddNew
  Case adRsnClose
  Case adRsnDelete
  Case adRsnFirstChange
  Case adRsnMove
  Case adRsnRequery
  Case adRsnResynch
  Case adRsnUndoAddNew
  Case adRsnUndoDelete
  Case adRsnUndoUpdate
  Case adRsnUpdate
  End Select

  If bCancel Then adStatus = adStatusCancel
End Sub

Private Sub cmdAdd_Click()
  On Error GoTo AddErr
  
  Dim SchedID As String
  Dim flag As Boolean
  Dim rsSched As Recordset
  Dim i As Integer
  Set rsSched = New ADODB.Recordset
  
  
   For i = 0 To 6
        chkDay(i).Value = 0
    Next
   
        SchedID = Functions.UID(6, "SchedID_")
        rsSched.Open "Select * from Doctor_Schedule_Details", cnPatients, adOpenKeyset, adLockPessimistic
              
            While rsSched.EOF = False
                If rsSched(0) = SchedID Then
                   SchedID = Functions.UID(6, "SchedID_")
                   rsSched.MoveFirst
                    flag = True
                Else
                    flag = False
                End If
                rsSched.MoveNext
            Wend
            
  
            rsSched.Close

    cmbDoctorID.clear
    rsSched.Open "SELECT * FROM Doctor_Details", cnPatients, adOpenKeyset, adLockPessimistic
    i = 0
    ' Add ID's to Combo Box
    
    While rsSched.EOF = False
        cmbDoctorID.AddItem rsSched(0)
        cmbDoctorID.ListIndex = i
        i = i + 1
        rsSched.MoveNext
    Wend
   cmbDoctorID.Text = cmbDoctorID.List(0)
   rsSched.Close
            
  
   
  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    End If
    .AddNew
    
    cmbDoctorID.Visible = True
    txtFields(1).Visible = False
    txtFields(1) = cmbDoctorID.Text
    txtTempDocID = cmbDoctorID.Text
    
    lblStatus.Caption = "Add record"
    frameDays.Visible = True
    txtFields(0).Text = SchedID
    
    Dim oText As TextBox
    
    For Each oText In Me.txtFields
        oText.Locked = False
    Next
    
    txtFields(0).Locked = True
    txtFields(1).Locked = True
    
    
    
    mbAddNewFlag = True
    SetButtons False
  End With

  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DeleteErr
  
  If MsgBox("Are you sure you want to delete this record?", vbQuestion + vbYesNo, "Confirm Delete") = vbNo Then
    Exit Sub
  End If
  
  
  With adoPrimaryRS
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
  Set grdDataGrid.DataSource = Nothing
  adoPrimaryRS.Requery
  Set grdDataGrid.DataSource = adoPrimaryRS("ChildCMD").UnderlyingValue
  
  
  Exit Sub
DeleteErr:
  MsgBox Err.Description
End Sub

Private Sub cmdRefresh_Click()
  'This is only needed for multi user apps
  On Error GoTo RefreshErr
  Set grdDataGrid.DataSource = Nothing
  adoPrimaryRS.Requery
  Set grdDataGrid.DataSource = adoPrimaryRS("ChildCMD").UnderlyingValue
  Exit Sub
RefreshErr:
  MsgBox Err.Description
End Sub

Private Sub cmdEdit_Click()
  Dim rsSched As Recordset
  Dim i As Integer
  Set rsSched = New ADODB.Recordset

   Dim oText As TextBox
   Dim strDays As String
   Dim arrDays() As String
  On Error GoTo EditErr
    cmbDoctorID.clear
  
    rsSched.Open "SELECT * FROM Doctor_Details", cnPatients, adOpenKeyset, adLockPessimistic
    i = 0
    ' Add ID's to Combo Box
    
    While rsSched.EOF = False
        cmbDoctorID.AddItem rsSched(0)
        cmbDoctorID.ListIndex = i
        i = i + 1
        rsSched.MoveNext
    Wend
    rsSched.Close
    
    strDays = txtFields(4)
    arrDays() = Split(strDays, ",")
    
    For i = 0 To 6
        chkDay(i).Value = 0
    Next
    
    For i = 0 To UBound(arrDays)
               
        If arrDays(i) = "Sun" Then
            chkDay(0).Value = 1
        End If
        If arrDays(i) = "Mon" Then
            chkDay(1).Value = 1
        End If
        If arrDays(i) = "Tue" Then
           chkDay(2).Value = 1
        End If
        If arrDays(i) = "Wed" Then
            chkDay(3).Value = 1
        End If
        If arrDays(i) = "Thu" Then
            chkDay(4).Value = 1
        End If
        If arrDays(i) = "Fri" Then
            chkDay(5).Value = 1
        End If
        If arrDays(i) = "Sat" Then
            chkDay(6).Value = 1
        End If
        
    Next i
    
    
    

  lblStatus.Caption = "Edit record"
    
    frameDays.Visible = True
    For Each oText In Me.txtFields
        oText.Locked = False
    Next
    txtFields(0).Locked = True
  
  
  cmbDoctorID.Visible = True
  cmbDoctorID.Text = txtFields(1).Text
  txtTempDocID = cmbDoctorID.Text
  DTPin.Value = txtFields(2)
  DTPout.Value = txtFields(3)
  
  
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub
Private Sub cmdCancel_Click()
  
  On Error GoTo CancelError
  
    frameDays.Visible = False
    If Right(txtFields(4), 1) = "," Then
        txtFields(4).Text = Left(txtFields(4), Len(txtFields(4)) - 1)
    End If
    
    Dim oText As TextBox
    For Each oText In Me.txtFields
        oText.Locked = True
    Next
    txtFields(0).Locked = True
    txtFields(1).Visible = True
    cmbDoctorID.Visible = False
  
  

  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  
  adoPrimaryRS.CancelUpdate
  
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
  Else
    adoPrimaryRS.MoveFirst
  End If
  

    mbDataChanged = False
    
 
Exit Sub

CancelError:
  MsgBox Err.Description

End Sub

Private Sub cmdUpdate_Click()
Dim oText As TextBox

  On Error GoTo UpdateErr
  
  txtFields(1) = cmbDoctorID.Text
  txtFields(4) = txtDay
  txtFields(2) = Format(DTPin.Value, "Short time")
  txtFields(3) = Format(DTPout.Value, "short time")
  
  MsgBox txtFields(2)

    If Right(txtFields(4), 1) = "," Then
        txtFields(4).Text = Left(txtFields(4), Len(txtFields(4)) - 1)
    End If
    
    If Trim(txtFields(2)) = "" Or Trim(txtFields(3)) = "" Or txtFields(4) = "" Then
        MsgBox "Please fill all the relavent fields", vbCritical, "An Error Occured"
        Exit Sub
    End If
    
    
    
  adoPrimaryRS.UpdateBatch adAffectAll

  If mbAddNewFlag Then
    adoPrimaryRS.MoveLast              'move to the new record
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = False
  
  For Each oText In Me.txtFields
    oText.Locked = True
  Next
  txtFields(1) = txtTempDocID
  txtFields(1).Visible = True
  cmbDoctorID.Visible = False
  
  
  frameDays.Visible = False
  
  
  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Private Sub cmdFirst_Click()
  On Error GoTo GoFirstError

  adoPrimaryRS.MoveFirst
  mbDataChanged = False

  Exit Sub

GoFirstError:
  MsgBox Err.Description
End Sub

Private Sub cmdLast_Click()
  On Error GoTo GoLastError

  adoPrimaryRS.MoveLast
  mbDataChanged = False

  Exit Sub

GoLastError:
  MsgBox Err.Description
End Sub

Private Sub cmdNext_Click()
  On Error GoTo GoNextError

  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
     'moved off the end so go back
    adoPrimaryRS.MoveLast
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub
GoNextError:
  MsgBox Err.Description
End Sub

Private Sub cmdPrevious_Click()
  On Error GoTo GoPrevError

  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    'moved off the end so go back
    adoPrimaryRS.MoveFirst
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub

GoPrevError:
  MsgBox Err.Description
End Sub

Private Sub SetButtons(bVal As Boolean)
  cmdAdd.Visible = bVal
  cmdEdit.Visible = bVal
  cmdShowAll.Visible = Not bVal
  cmdUpdate.Visible = Not bVal
  cmdCancel.Visible = Not bVal
  cmdDelete.Visible = bVal
  cmdClose.Visible = bVal
  cmdRefresh.Visible = bVal
  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
  txtFields(4).Locked = Not bVal
  txtFields(1).Locked = Not bVal
  txtTempDocID.Visible = Not bVal
  
  txtDay.Visible = Not bVal
  
  DTPin.Visible = Not bVal
  DTPout.Visible = Not bVal
End Sub