frmcpbm.frm

vb程序设计仁宇人份管理

         Height          =   255
         Index           =   5
         Left            =   360
         TabIndex        =   30
         Top             =   2025
         Width           =   1815
      End
      Begin VB.Label lblLabels 
         Caption         =   "产品种类:       **"
         Height          =   255
         Index           =   6
         Left            =   360
         TabIndex        =   29
         Top             =   2400
         Width           =   1815
      End
      Begin VB.Label lblLabels 
         Caption         =   "技术标准:"
         Height          =   255
         Index           =   7
         Left            =   360
         TabIndex        =   28
         Top             =   2760
         Width           =   1815
      End
      Begin VB.Label Label1 
         Caption         =   "注意：带**号的字段不能为空"
         Height          =   255
         Left            =   120
         TabIndex        =   27
         Top             =   0
         Width           =   2535
      End
   End
End
Attribute VB_Name = "frmCPBM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'实现对产品编码表的维护
Dim WithEvents adoPrimaryRS As Recordset
Attribute adoPrimaryRS.VB_VarHelpID = -1
Dim mbChangedByCode As Boolean
Dim mvBookMark As Variant
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Dim mbDataChanged As Boolean
Dim rsCpbm As Recordset
Dim rscpbm1 As Recordset
'用方向键移动光标
Private Sub cmdAdd_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then SendKeys "{tab}"
End Sub
'查询
Private Sub cmdQuery_Click()
Me.Hide
frmcpbmcx.Show
End Sub
'双击查询界面激活此窗口时当前记录所在的位置
Private Sub Form_Activate()
    If Me.Tag <> "" Then
        adoPrimaryRS.MoveFirst
        adoPrimaryRS.Find ("产品编码='" & Me.Tag & "'")
    End If
        
End Sub

Private Sub Form_Load()
  Set rsCpbm = New Recordset
  rsCpbm.Open "select 产品编码,产品名称 from cpbm order by 产品编码", dblgjx, adOpenStatic, adLockOptimistic
 
  Set rscpbm1 = New Recordset
  rscpbm1.Open "select 产品编码,产品名称 from cpbm order by 产品编码", dblgjx, adOpenStatic, adLockOptimistic
 
  Set adoPrimaryRS = New Recordset
  adoPrimaryRS.Open "select 产品编码,产品名称,规格,钢号,尺寸,计量单位,产品种类,技术标准,理论计重,技协费,探伤费,每捆支数 from CPBM Order by 产品编码", dblgjx, adOpenStatic, adLockOptimistic

  Dim oText As TextBox
  '绑定文本框到数据提供者
  For Each oText In Me.txtFields
    Set oText.DataSource = adoPrimaryRS
  Next
  mbDataChanged = False
End Sub

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 显示当前记录位置
  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
    Frame1.Enabled = True
    If txtFields(0).Enabled = False Then txtFields(0).Enabled = True
    txtFields(0).SetFocus

  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    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
  Frame1.Enabled = True
  txtFields(0).Enabled = False
  lblStatus.Caption = "编辑记录"
  mbEditFlag = True
  SetButtons False
  Exit Sub

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

End Sub
'保存
Private Sub cmdUpdate_Click()
 On Error GoTo UpdateErr
 If Trim(txtFields(0).Text) = "" Or Trim(txtFields(1).Text) = "" Or Trim(txtFields(2).Text) = "" Or _
     Trim(txtFields(6).Text) = "" Then
         MsgBox "带**号的字段不能为空，请您填写！！", , "注意！"
         Exit Sub
 End If
 If mbAddNewFlag Then
    rscpbm1.MoveFirst
    While Not rscpbm1.EOF
      If rscpbm1(0) = Trim(txtFields(0)) Then
          MsgBox "产品编码不可重复,请重新输入!", 48, "警告"
          txtFields(0).SetFocus
          Exit Sub
      End If
      rscpbm1.MoveNext
    Wend
 End If
 Frame1.Enabled = False
'滤掉空格
For i = 0 To 7
  txtFields(i) = Trim(txtFields(i))
Next
   
'保存
  adoPrimaryRS.UpdateBatch adAffectAll

  If mbAddNewFlag Then
    strzc = "添加产品编码：" & Trim(txtFields(0)) & "。"
    dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
    adoPrimaryRS.MoveLast              '移到新记录
  End If
  
 If mbEditFlag Then
    strzc = "修改产品编码：" & Trim(txtFields(0)) & "。"
    dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
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 txtFields_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then SendKeys "{tab}"
End Sub
'辅助下拉框显示
Private Sub txtFields_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
On Error GoTo kperr
  If Index = 0 And Trim(txtFields(0)) <> "" Then
      ListHelpCpbm.Visible = True
      rsCpbm.Filter = "产品编码 like '" & Trim(txtFields(0).Text) & "%'"
      rsCpbm.Requery
   If rsCpbm.RecordCount > 0 Then
     rsCpbm.MoveFirst
     If (KeyCode >= 48 And KeyCode <= 57) Or (KeyCode >= 96 And KeyCode <= 105) Then
        ListHelpCpbm.Clear
        For i = 1 To rsCpbm.RecordCount
             ListHelpCpbm.AddItem rsCpbm(0) & Space(12 - Len(rsCpbm(0))) & rsCpbm(1)
             rsCpbm.MoveNext
        Next
     End If
   End If
  End If
  Exit Sub
kperr:
   MsgBox Err.Description
End Sub

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