frmxcp.frm

vb程序设计仁宇人份管理

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

End Sub

Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
If Rs.State = adStateOpen Then Rs.Close
If Rs1.State = adStateOpen Then Rs1.Close
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 显示当前记录位置
  'DTPicker1.Value = adoPrimaryRS(0)
  
  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)
  '验证代码置于此处
  '下列动作发生时该事件被调用
  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
  If txtFields.Enabled = False Then txtFields.Enabled = True
  If DTPicker1.Enabled = False Then DTPicker1.Enabled = True
  
  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    End If
 
    DTPicker1.Value = Date
    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
  
  txtFields.Enabled = False
  DTPicker1.Enabled = True
  
  lblStatus.Caption = "修改记录"
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub
'取消操作
Private Sub cmdCancel_Click()
  On Error Resume Next
  txtFields.Enabled = False
  DTPicker1.Enabled = False
  txtCpmc.Enabled = False
  txtGg.Enabled = False
  
  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
  Else
    adoPrimaryRS.MoveFirst
  End If
  mbDataChanged = False
 
  GetData          '''''''''写数据

End Sub
'保存
Private Sub cmdUpdate_Click()
 'On Error GoTo UpdateErr
   LstCpbm.Visible = False
   If mbAddNewFlag Then
             Rs1.Requery
             Rs1.MoveFirst
             While Not Rs1.EOF
               If Rs1(0) = Trim(txtFields) Then
                  Beep
                  MsgBox "新产品编码表中已经有此编码 ," & Chr(10) & "产品编码不可重复,请重新输入!", 64, "提示"
                  txtFields.SetFocus
                  Exit Sub
               End If
               Rs1.MoveNext
             Wend
  End If
  
  If mbAddNewFlag Then
    Dim i As Integer
    Dim Existed As Boolean
    Existed = False
    rsCpbm.MoveFirst
    For i = 1 To rsCpbm.RecordCount
       If rsCpbm(0) = Trim(txtFields) Then
           Existed = True
           Exit For
       End If
       rsCpbm.MoveNext
    Next
    If Not Existed Then
       MsgBox "产品编码表中不存在此编码，请重新输入！", 64, "提示"
       txtFields.SetFocus
       Exit Sub
    Else
       txtCpmc = rsCpbm(1)
       txtGg = rsCpbm(1)
    End If
    '写数据库
    dblgjx.Execute "insert into xcp values(to_date('" & Format(DTPicker1.Value, "yyyymmdd") & "','yyyy-mm-dd'),'" & Trim(txtFields) & "','" & Trim(txtCpmc) & "','" & Trim(txtGg) & "')"
    '写日志--添加
    strzc = "添加新产品编码：" & Trim(txtFields) & "。"
    dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
    dblgjx.Execute "commit"
  End If

   If mbEditFlag Then
      dblgjx.Execute "update xcp set 日期 = to_date('" & Format(DTPicker1.Value, "yyyymmdd") & "' ,'yyyy-mm-dd'),产品名称='" & Trim(txtCpmc) & "',规格='" & Trim(txtGg) & "' where 新产品编码='" & Trim(txtFields) & "'"
      '写日志--修改
      strzc = "修改新产品编码：" & Trim(txtFields) & "。"
      dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
      dblgjx.Execute "commit"
  End If
  
  adoPrimaryRS.Requery
  
  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = False
DTPicker1.Enabled = False
txtFields.Enabled = False
txtCpmc.Enabled = 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
  GetData         '''''''''''写数据
  Exit Sub
GoFirstError:
  MsgBox Err.Description
End Sub
'移到最后一条记录
Private Sub cmdLast_Click()
  On Error GoTo GoLastError

  adoPrimaryRS.MoveLast
  mbDataChanged = False
  GetData     ''''''''''''''写数据
  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
  GetData
  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
  GetData      ''''''''''写数据
  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 LstCpbm_KeyDown(KeyCode As Integer, Shift As Integer)
Dim X As Integer
If KeyCode = vbKeyReturn Then
X = InStr(LstCpbm.Text, " ")
txtFields.Text = Left(LstCpbm.Text, X - 1)
LstCpbm.Visible = False
End If
End Sub
'产品编码输入下拉框显示
Private Sub txtFields_Change()
On Error Resume Next
Dim i As Integer
Dim X As Integer
If mbAddNewFlag = True Or mbEditFlag = True Then
LstCpbm.Move txtFields.Left, txtFields.Height + txtFields.Top
LstCpbm.Clear
LstCpbm.Visible = True

X = Len(Trim(txtFields.Text))
If X > 0 Then
Rs.Filter = "产品编码 like '" & Trim(txtFields.Text) & "%'"

If Rs.RecordCount > 0 Then
i = 0
Do
    i = i + 1
    LstCpbm.AddItem Rs!产品编码 & Space(13 - Len(Rs("产品编码"))) & Rs!产品名称 & Space(21 - Len(Rs("产品名称"))) & Rs!规格
    Rs.MoveNext
Loop While Not Rs.EOF And i < 10
End If
End If
End If


End Sub
'方向键移动光标
Private Sub txtFields_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyDown Then
    LstCpbm.SetFocus
End If
End Sub

Private Sub txtFields_Validate(Cancel As Boolean)
If mbAddNewFlag = True Or mbEditFlag = True Then
'txtFields.text = LstCpbm.text
LstCpbm.Visible = False
End If
End Sub