frmbmbm.frm

vb程序设计仁宇人份管理

Private Sub Form_Resize()
  On Error Resume Next
  lblStatus.Width = Me.Width - 1500
  cmdNext.Left = lblStatus.Width + 700
  cmdLast.Left = cmdNext.Left + 340
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If mbEditFlag Or mbAddNewFlag Then Exit Sub

  Select Case KeyCode
    Case vbKeyEscape
      cmdClose_Click
    Case vbKeyEnd
      cmdLast_Click
    Case vbKeyHome
      cmdFirst_Click
    Case vbKeyUp, vbKeyPageUp
      If Shift = vbCtrlMask Then
        cmdFirst_Click
      Else
        cmdPrevious_Click
      End If
    Case vbKeyDown, vbKeyPageDown
      If Shift = vbCtrlMask Then
        cmdLast_Click
      Else
        CmdNext_Click
      End If
  End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
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)
  '为这个 recordset 显示当前记录位置
On Error GoTo rsmcerr
    lblStatus.Caption = "Record: " & CStr(adoPrimaryRS.AbsolutePosition)
    Exit Sub
    
rsmcerr:
     MsgBox Err.Description & Chr(10) & "请点[刷新]重新开始！"
End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  '验证代码置于此处
  '下列动作发生时该事件被调用
  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
  opAdded = True
  Framefields.Enabled = True
  If txtFields(0).Enabled = False Then txtFields(0).Enabled = True
  txtFields(0).SetFocus
  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMarkA = .AbsolutePosition
    End If
    .AddNew
    lblStatus.Caption = "添加记录"
    mbAddNewFlag = True
    SetButtons False
  End With

  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub

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

Private Sub cmdEdit_Click()
'修改
  On Error GoTo EditErr
  opEdited = True
  Framefields.Enabled = True
  txtFields(0).Enabled = False
With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMarkE = .AbsolutePosition
    End If
End With

  lblStatus.Caption = "编辑记录"
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub
'取消
Private Sub cmdCancel_Click()
  On Error Resume Next
  Framefields.Enabled = False
  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate
If opEdited Then
  opEdited = False
  If mvBookMarkE > 0 Then
    adoPrimaryRS.AbsolutePosition = mvBookMarkE
  Else
    adoPrimaryRS.MoveFirst
  End If
 End If
 
 If opAdded Then
  opAdded = False
  If mvBookMarkA > 0 Then
    adoPrimaryRS.AbsolutePosition = mvBookMarkA
  Else
    adoPrimaryRS.MoveFirst
  End If
 End If
 
  mbDataChanged = False
End Sub
'保存
Private Sub cmdUpdate_Click()
   On Error GoTo UpdateErr
   If Trim(txtFields(0).Text) = "" Or Trim(txtFields(1).Text) = "" Then
        MsgBox "带**号的字段不能为空，请您填写！！", , "注意！"
        Exit Sub
   End If
   If opAdded Then
        ListHelpBmbm.Visible = False
        rsBmbm1.MoveFirst
        While Not rsBmbm1.EOF
         If rsBmbm1(0) = Trim(txtFields(0)) Then
            MsgBox "部门编码不可重复,请重新输入!", 48, "警告"
            txtFields(0).SetFocus
            Exit Sub
        End If
         rsBmbm1.MoveNext
     Wend
        strzc = "添加部门编码：" & Trim(txtFields(0)) & "。"
        dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
        opAdded = False
   End If
   If opEdited Then
        strzc = "修改部门编码：" & Trim(txtFields(0)) & "。"
        dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
        opEdited = False
   End If
  For i = 0 To 1
    txtFields(i) = Trim(txtFields(i))
  Next
  Framefields.Enabled = False
  adoPrimaryRS.UpdateBatch adAffectAll

  If mbAddNewFlag Then
    adoPrimaryRS.MoveLast              '移到新记录
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = 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
     '已到最后返回
    adoPrimaryRS.MoveLast
  End If
  '显示当前记录
  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
    '已到最后返回
    adoPrimaryRS.MoveFirst
  End If
  '显示当前记录
  mbDataChanged = False
  Exit Sub
GoPrevError:
  MsgBox Err.Description
End Sub

Private Sub SetButtons(bVal As Boolean)
  cmdAdd.Visible = bVal
  cmdEdit.Visible = bVal
  cmdUpdate.Visible = Not bVal
  cmdCancel.Visible = Not bVal
  'cmdDelete.Visible = bVal
  cmdQuery.Visible = bVal
  cmdClose.Visible = bVal
  cmdRefresh.Visible = bVal
  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
End Sub

Private Sub Framefields_Click()
ListHelpBmbm.Visible = False
End Sub

Private Sub txtFields_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then SendKeys "{tab}"
If KeyCode = vbKeyUp And Index <> 0 Then txtFields(Index - 1).SetFocus
If KeyCode = vbKeyDown And Index <> 1 Then txtFields(Index + 1).SetFocus
End Sub
'文本框输入时的辅助下拉框显示
Private Sub txtFields_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
 If Index = 0 Then
    rsBmbm.MoveFirst
    ListHelpBmbm.Visible = True
    If (KeyCode >= 48 And KeyCode <= 57) Or (KeyCode >= 96 And KeyCode <= 105) Then
      ListHelpBmbm.Clear
      For i = 1 To rsBmbm.RecordCount
                    ListHelpBmbm.AddItem rsBmbm(0) & Space(6 - Len(rsBmbm(0))) & rsBmbm(1)
                    rsBmbm.MoveNext
      Next
    End If
 End If
End Sub

Private Sub txtFields_LostFocus(Index As Integer)
If Index = 0 Then ListHelpBmbm.Visible = False
End Sub