form1.frm

简单的社区卫生服务软件,家庭成员数据库可从计划生育指导站取得,因上传时已清空数据库运行时可能出错。内含dbgrid32.ocx。

         Top             =   1005
         Width           =   1815
      End
      Begin VB.Label lblLabels 
         Caption         =   "姓名:"
         Height          =   255
         Index           =   1
         Left            =   240
         TabIndex        =   14
         Top             =   675
         Width           =   1815
      End
      Begin VB.Label lblLabels 
         Caption         =   "家庭编号:"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   13
         Top             =   360
         Width           =   1815
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdFirst_Click()
  On Error GoTo GoFirstError

  datPrimaryRS.Recordset.MoveFirst
  mbDataChanged = False
 
  Exit Sub

GoFirstError:
  MsgBox Err.Description

End Sub

Private Sub cmdLast_Click()
  On Error GoTo GoLastError

  datPrimaryRS.Recordset.MoveLast
  mbDataChanged = False
 
  Exit Sub

GoLastError:
  MsgBox Err.Description

End Sub

Private Sub cmdNext_Click()
  On Error GoTo GoNextError

  If Not datPrimaryRS.Recordset.EOF Then datPrimaryRS.Recordset.MoveNext
  If datPrimaryRS.Recordset.EOF And datPrimaryRS.Recordset.RecordCount > 0 Then
    Beep
     '已到最后返回
    datPrimaryRS.Recordset.MoveLast
  End If
  '显示当前记录
  mbDataChanged = False


  Exit Sub
GoNextError:
  MsgBox Err.Description

End Sub

Private Sub cmdPrevious_Click()
  On Error GoTo GoPrevError

  If Not datPrimaryRS.Recordset.BOF Then datPrimaryRS.Recordset.MovePrevious
  If datPrimaryRS.Recordset.BOF And datPrimaryRS.Recordset.RecordCount > 0 Then
    Beep
    '已到最后返回
    datPrimaryRS.Recordset.MoveFirst
  End If
  '显示当前记录
  mbDataChanged = False
 
  Exit Sub

GoPrevError:
  MsgBox Err.Description

End Sub



Private Sub Combo16_Change()
Combo17(0).SetFocus
End Sub

Private Sub Combo17_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 And Index < 6 Then
Select Case Index
Case Index
If Combo17(Index).Text = "1" Then Combo17(Index).Text = "经常"
If Combo17(Index).Text = "2" Then Combo17(Index).Text = "偶尔"
If Combo17(Index).Text = "3" Then Combo17(Index).Text = "从不"

Combo17(Index + 1).SetFocus
End Select
End If
If KeyAscii = 13 And Index = 6 Then
If Combo17(6).Text = "1" Then Combo17(Index).Text = "经常"
If Combo17(6).Text = "2" Then Combo17(Index).Text = "偶尔"
If Combo17(6).Text = "3" Then Combo17(Index).Text = "从不"
Call Command5_Click
Call Command9_Click
txtFields(7).SetFocus
End If

End Sub

Private Sub Command1_Click()
  On Error GoTo GoFirstError

  Adodc1.Recordset.MoveFirst
  mbDataChanged = False
   
  Exit Sub

GoFirstError:
  MsgBox Err.Description

End Sub

Private Sub Command10_Click()
  '只有多用户应用程序需要

On Error GoTo ErrorHandler
    ' Test for proper input
If cboFields = "" Then
    MsgBox "Select a field to search", vbInformation + vbOKOnly, "Missing Parameter"
    Exit Sub
End If
    If Trim(Text2.Text) = "" Then
       Answer = MsgBox("Need String Search", vbOKOnly + vbCritical, "Warning")
        Exit Sub
    End If
' Apply Filter

 Adodc1.RecordSource = "SELECT * FROM 健康档案 WHERE " & Combo1.Text & " Like " & Chr$(39) & Text2.Text & Chr$(39)
Adodc1.Refresh
 datPrimaryRS.Recordset.FindFirst "家庭编号 Like " & Chr$(39) & Text1.Text & Chr$(39)

   
Exit Sub
ErrorHandler:
MsgBox Error$

End Sub

Private Sub Command11_Click()
  On Error GoTo UpdateErr
  Adodc2.Recordset.Edit
  Adodc2.Recordset.Update
  Exit Sub
UpdateErr:
  MsgBox Err.Description

End Sub

Private Sub Command12_Click()
  On Error GoTo DeleteErr
  With Adodc2.Recordset
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
  Exit Sub
DeleteErr:
  MsgBox Err.Description

End Sub

Private Sub Command13_Click()
  '只有多用户应用程序需要
  On Error GoTo RefreshErr
  Adodc2.Refresh
  Exit Sub
RefreshErr:
  MsgBox Err.Description

End Sub

Private Sub Command14_Click()
  On Error GoTo GoLastError

  Adodc1.Recordset.MoveLast
  mbDataChanged = False
   
  Exit Sub

GoLastError:
  MsgBox Err.Description

End Sub

Private Sub Command17_Click()

End Sub

Private Sub Command2_Click()
  '只有多用户应用程序需要

On Error GoTo ErrorHandler
    ' Test for proper input
If cboFields = "" Then
    MsgBox "Select a field to search", vbInformation + vbOKOnly, "Missing Parameter"
    Exit Sub
End If
    If Trim(txtSearch.Text) = "" Then
       Answer = MsgBox("Need String Search", vbOKOnly + vbCritical, "Warning")
        Exit Sub
    End If
' Apply Filter
  datPrimaryRS.Recordset.FindFirst cboFields & " Like " & Chr$(39) & txtSearch & Chr$(39)

   
Exit Sub
ErrorHandler:
MsgBox Error$

End Sub


Private Sub Command3_Click()
  On Error GoTo AddErr
  Adodc2.Recordset.AddNew
  Text5.Text = txtFields(6).Text
  Adodc2.Recordset.Filter = "ID Like " & Chr$(39) & txtFields(6).Text & Chr$(39)
    Adodc2.Recordset.MoveLast
  Exit Sub
AddErr:
  MsgBox Err.Description

End Sub

Private Sub Command30_Click()
End Sub






Private Sub Command36_Click()
Adodc1.Recordset.MoveNext
   
End Sub


Private Sub Command4_Click()
  On Error GoTo AddErr
  Adodc1.Recordset.AddNew
  Text1.Text = txtFields(0).Text
  Adodc1.Recordset.Filter = "家庭编号 Like " & Chr$(39) & txtFields(0) & Chr$(39)
  Adodc1.Recordset.MoveLast
  Exit Sub
AddErr:
  MsgBox Err.Description

End Sub

Private Sub Command5_Click()
  On Error GoTo UpdateErr
  Adodc1.Recordset.Edit
  Adodc1.Recordset.Update
  Exit Sub
UpdateErr:
  MsgBox Err.Description

End Sub

Private Sub Command6_Click()
  On Error GoTo DeleteErr
  With Adodc1.Recordset
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
  Exit Sub
DeleteErr:
  MsgBox Err.Description

End Sub

Private Sub Command7_Click()
Form2.Show
Me.Hide
End Sub

Private Sub Command8_Click()
  On Error GoTo GoPrevError

  If Not Adodc1.Recordset.BOF Then Adodc1.Recordset.MovePrevious
  If Adodc1.Recordset.BOF And Adodc1.Recordset.RecordCount > 0 Then
    Beep
    '已到最后返回
    Adodc1.Recordset.MoveFirst
  End If
  '显示当前记录
  mbDataChanged = False
   
  Exit Sub

GoPrevError:
  MsgBox Err.Description

End Sub

Private Sub Command9_Click()
  On Error GoTo GoNextError

  If Not Adodc1.Recordset.EOF Then Adodc1.Recordset.MoveNext
  If Adodc1.Recordset.EOF And Adodc1.Recordset.RecordCount > 0 Then
    Beep
     '已到最后返回
    Adodc1.Recordset.MoveLast
  End If
  '显示当前记录
  mbDataChanged = False

  Exit Sub
GoNextError:
  MsgBox Err.Description

End Sub


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



Private Sub cmdAdd_Click()
Dialog.Show
Me.Hide
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DeleteErr
  With datPrimaryRS.Recordset
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
  Exit Sub
DeleteErr:
  MsgBox Err.Description
End Sub

Private Sub cmdRefresh_Click()
  '只有多用户应用程序需要
  On Error GoTo RefreshErr
  datPrimaryRS.Refresh
  Exit Sub
RefreshErr:
  MsgBox Err.Description
End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr
  
  datPrimaryRS.Recordset.Edit
  datPrimaryRS.Recordset.Update
  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub

Private Sub cmdClose_Click()
 datPrimaryRS.Recordset.Move Text4.Text, 1
  

End Sub


Private Sub Text2_KeyPress(KeyAscii As Integer)
  '只有多用户应用程序需要
If KeyAscii = 13 Then
Call Command10_Click
Exit Sub
End If
End Sub


Private Sub Text4_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
On Error GoTo ErrorHandler
    ' Test for proper input
    If Trim(Text4.Text) = "" Then
       Answer = MsgBox("Need String Search", vbOKOnly + vbCritical, "Warning")
        Exit Sub
    End If
' Apply Filter
datPrimaryRS.Recordset.FindFirst "ID like '" + Text4.Text + "'" '
  
Exit Sub
ErrorHandler:
MsgBox Error$
End If

End Sub

Private Sub txtFields_Change(Index As Integer)
If Index = 0 Then
Adodc1.RecordSource = "SELECT * FROM 健康档案 WHERE 家庭编号 Like " & Chr$(39) & txtFields(0) & Chr$(39)
Adodc1.Refresh
End If


If Index = 6 Then
Adodc2.RecordSource = "SELECT * FROM 服务记录 WHERE ID Like " & Chr$(39) & txtFields(6).Text & Chr$(39)
Adodc2.Refresh
End If

End Sub

Private Sub txtFields_GotFocus(Index As Integer)
Select Case Index
Case Index
txtFields(Index).SelLength = Len(txtFields(Index).Text)
End Select
If Index = 7 And txtFields(7) = "" Then txtFields(7) = txtFields(5)
If Index = 8 And Check1.Value = 0 Then txtFields(9).SetFocus
If Index = 13 And txtFields(13) = "" Then txtFields(13) = "端正"
If Index = 14 And txtFields(14) = "" Then txtFields(14) = "心律齐，未闻及杂音"
If Index = 15 And txtFields(15) = "" Then txtFields(15) = "（-)"
If Index = 16 And txtFields(16) = "" Then txtFields(16) = "未触及"
If Index = 17 And txtFields(17) = "" Then txtFields(17) = "未触及"
End Sub

Private Sub txtFields_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 And Index < 17 Then
Select Case Index
Case Index
txtFields(Index + 1).SetFocus
End Select
If Index = 5 Then
Call cmdUpdate_Click
End If
End If
If KeyAscii = 13 And Index = 17 Then
Combo17(0).SetFocus
End If
End Sub

Private Sub txtSearch_KeyPress(KeyAscii As Integer)
  '只有多用户应用程序需要
If KeyAscii = 13 Then
Call Command2_Click
   
End If
End Sub