frmkhbm.frm

vb程序设计仁宇人份管理

  For i = 0 To 23
    txtFields(i) = ""
  Next
  
  GetData          '''''''''''写数据至文本框
  
  If txtFields(15).Enabled = False Then txtFields(15).Enabled = True
  If txtFields(15).BackColor = &H80000005 Then txtFields(15).BackColor = &HE0E0E0
  Frame.Enabled = False
  
  ResumeColor       '''''''''''恢复文本框颜色
  
  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
  Else
    adoPrimaryRS.MoveFirst
  End If
  mbDataChanged = False
  cmdClose.Enabled = True
  cmdQuery.Enabled = True
  cmdAdd.Enabled = True
  cmdEdit.Visible = True
  cmdUpdate.Visible = False
  
  opAdded = False
  opEdited = False
End Sub
'保存
Private Sub cmdUpdate_Click()
    Dim rsKhJc As New ADODB.Recordset
    Dim i As String
    On Error GoTo UpdateErr
    dblgjx.BeginTrans
   
    If Trim(txtFields(14)) <> "" And (Not IsNumeric(txtFields(14)) Or Len(Trim(txtFields(14))) > 1) Then
      MsgBox "发货性质只能有一位！！" & Chr(10) & "发货性质必须为数字！！", 48, "注意！"
      txtFields(14).SetFocus
      Exit Sub
    End If
    '检查添加时的填写是否规范
    If opAdded Then
       If rsKhJc.State = adStateOpen Then rsKhJc.Close
        rsKhJc.Open "select * from khbm where 客户序号='" & txtFields(0).Text & "' and 最新标志='1'", dblgjx, adOpenDynamic, adLockOptimistic
       If Not rsKhJc.EOF Then
          i = MsgBox("已有其他客户使用了该客户序号,你确定要填此客户序号请按[确定]，否则按[取消]", 1)
         If i <> "1" Then
           dblgjx.RollbackTrans
           Exit Sub
         End If
       End If
       If rsKhJc.EOF Or ((Not rsKhJc.EOF) And i = "1") Then
      
       
         If Trim(txtFields(0).Text) = "" Or Trim(txtFields(1).Text) = "" Or Trim(txtFields(2).Text) = "" Or _
             Trim(txtFields(13).Text) = "" Or Trim(txtFields(11).Text) = "" Or Trim(txtFields(12).Text) = "" Then
             MsgBox "带**号的字段不能为空，请您填写！！", , "注意！"
             dblgjx.RollbackTrans
             Exit Sub
         End If
         
         Dim rsTemp As Recordset
         Set rsTemp = New Recordset
    
         If rsTemp.State = adStateOpen Then rsTemp.Close
         rsTemp.Open "select 单位编码,单位名称,简称 from khbm where 最新标志 = '1'", dblgjx, adOpenStatic, adLockOptimistic
      '辅助下拉框显示
      rsTemp.MoveFirst
      While Not rsTemp.EOF
           If Trim(txtFields(1).Text) = rsTemp(0) And Trim(txtFields(1)) <> "" Then
               MsgBox "客户编码不可重复,请您重新输入！！", 48, "注意！"
               txtFields(1).Text = ""
               txtFields(1).SetFocus
               dblgjx.RollbackTrans
               Exit Sub
           End If
           '判断单位名称是否重复
           If Trim(txtFields(2).Text) = rsTemp(1) Then
               MsgBox "单位名称不可重复,请您重新输入！！", 48, "注意！"
               dblgjx.RollbackTrans
               Exit Sub
           End If
           '判断简称是否重复
           If Trim(txtFields(3).Text) = rsTemp(2) And Trim(txtFields(3).Text) <> "" Then
               MsgBox "简称不可重复,请您重新输入！！", 48, "注意！"
               dblgjx.RollbackTrans
               Exit Sub
           End If
           rsTemp.MoveNext
      Wend
         '写日志
         strzc = "添加客户编码：" & Trim(txtFields(1)) & "。"
         dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.usercode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
         
         txtFields(15).Enabled = True  '恢复
         opAdded = False
         
      End If
  End If
  '检查修改时的填写是否规范
  If opEdited Then
      If Trim(txtFields(0).Text) = "" Or Trim(txtFields(1).Text) = "" Or Trim(txtFields(2).Text) = "" Or _
          Trim(txtFields(13).Text) = "" Or Trim(txtFields(11).Text) = "" Or Trim(txtFields(12).Text) = "" Then
          MsgBox "带**号的字段不能为空，请您填写！！", , "注意！"
          dblgjx.RollbackTrans
          Exit Sub
      End If
'写数据库
dblgjx.Execute " update khbm set 最新标志='0' where  最新标志='1' and 单位编码='" & Trim(txtFields(1)) & "'"
strzc = "修改客户编码：" & Trim(txtFields(1)) & "。"
dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.usercode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
If txtFields(15).BackColor = &H80000005 Then txtFields(15).BackColor = &HE0E0E0
      'opEdited = False    此处屏蔽之，以备下面修改预交（KHBM表修改后修改此处）
End If
   
   '省份、部门、地区文本框显示给用户的为名称，但写入数据库的为对应编码
   Dim BmStr As String
   Dim SfStr As String
   Dim zhDqstr As String
   Dim YwdqStr As String
   Dim Ssks As String
   '由名称查询对应编码
   rsBmbm.Filter = "部门名称='" & Trim(txtFields(11)) & "'"
   rsSfbm.Filter = "省份名称='" & Trim(txtFields(12)) & "'"
   rsDq.Filter = "地区名称='" & Trim(txtFields(18)) & "'"
   rsdqbm.Filter = "地区名称='" & Trim(txtFields(13)) & "'"
   BmStr = rsBmbm("部门编码")
   SfStr = rsSfbm("省份编码")
   zhDqstr = rsDq("地区编码")
   YwdqStr = rsdqbm("地区编码")
   '写科室名称对应的编码入数据库
   Select Case Trim(txtFields(22))
       Case "业务科一"
           Ssks = "A"
       Case "业务科二"
           Ssks = "B"
       Case "业务科三"
           Ssks = "C"
    End Select
   '写数据库
   
   dblgjx.Execute "insert into khbm(客户序号,单位编码,单位名称,简称,开户行,账号,税号,地址,电话," & _
    "传真,邮编,部门,省份,业务地区,发货性质,帐面余额,联系人,联系人电话,综合地区,电子信箱,主页," & _
    "法人,流水号,最新标志,所属科室,电挂)" & _
    " values('" & Trim(txtFields(0)) & "','" & Trim(txtFields(1)) & "'," & _
    "'" & Trim(txtFields(2)) & "','" & Trim(txtFields(3)) & "','" & Trim(txtFields(4)) & "'," & _
    "'" & Trim(txtFields(5)) & "'," & _
    "'" & Trim(txtFields(6)) & "','" & Trim(txtFields(7)) & "','" & Trim(txtFields(8)) & "'," & _
    "'" & Trim(txtFields(9)) & "','" & Trim(txtFields(10)) & "','" & BmStr & "'," & _
    "'" & SfStr & "'," & _
    "'" & YwdqStr & "'," & Trim(txtFields(14)) & "," & Trim(txtFields(15)) & "," & _
    "'" & Trim(txtFields(16)) & "','" & Trim(txtFields(17)) & "','" & zhDqstr & "'," & _
    "'" & Trim(txtFields(19)) & "','" & Trim(txtFields(20)) & "'," & _
    "'" & Trim(txtFields(21)) & "',lpad(khbm_id.nextval,10,'0'),'1','" & Ssks & "','" & Trim(txtFields(23)) & "')"
  '修改后的特殊处理
  If opEdited Then
      dblgjx.Execute "update khbm set 中板预交=" & Zbyj & ",中轧预交=" & Zzyj & ",一小轧预交=" & Yxzyj & "," & _
                     "二小轧预交=" & Exzyj & ",线材预交=" & Xcyj & " where 最新标志='1' and 单位编码=" & _
                     "'" & Trim(txtFields(1)) & "'"
      opEdited = False
  End If
  
  dblgjx.Execute "commit"
  dblgjx.CommitTrans
  adoPrimaryRS.Requery

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = False
  
  Frame.Enabled = False
  ResumeColor
  
  cmdQuery.Enabled = True
  cmdClose.Enabled = True
  cmdAdd.Enabled = True
  cmdCancel.Enabled = False
  cmdEdit.Visible = True
  cmdUpdate.Visible = False
  
  lblStatus.Caption = "记录已保存"
  
  txtFields(11).Text = rsBmbm("部门名称")
  txtFields(12).Text = rsSfbm("省份名称")
  txtFields(18).Text = rsDq("地区名称")
  
  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub
'关闭窗口
Private Sub cmdClose_Click()
Me.Hide
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)
  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
End Sub
'写数据模块(向对应的文本框中写数据)
Private Sub GetData()
For i = 0 To 21
    If adoPrimaryRS(i) <> "" Then
        txtFields(i) = adoPrimaryRS(i)
    Else
        txtFields(i) = ""
    End If
    Next
If adoPrimaryRS(30) <> "" Then txtFields(23) = adoPrimaryRS(30)

Select Case adoPrimaryRS(24)
       Case "a", "A"
           txtFields(22) = "业务科一"
       Case "b", "B"
           txtFields(22) = "业务科二"
       Case "c", "C"
           txtFields(22) = "业务科三"
End Select

End Sub
'不允许修改的文本框变灰
Private Sub Changecolor()
 For i = 0 To 3
    txtFields(i).BackColor = &HE0E0E0
     Next
End Sub
'恢复文本框颜色
Private Sub ResumeColor()
For i = 0 To 3
    txtFields(i).BackColor = &HFFFFFF
     Next
End Sub

Private Sub Frame_Click()
ListHelpSF.Visible = False
ListHelpBM.Visible = False
End Sub
'部门输入辅助下拉框添加记录
Public Sub ListHelpBM_Click()
  itemp1 = InStr(ListHelpBM.Text, " ")
  txtFields(11).Text = Trim(Mid(ListHelpBM.Text, itemp1, Len(ListHelpBM.Text) - itemp1 + 1))
  ListHelpBM.Visible = False
  txtFields(18).SetFocus
  BMlisthelpVisible = False
End Sub

Private Sub ListHelpBM_LostFocus()
BMlisthelpVisible = False
End Sub
'省份输入辅助下拉框添加记录
Public Sub listhelpsf_Click()
    itemp1 = InStr(ListHelpSF.Text, " ")
    txtFields(12).Text = Trim(Mid(ListHelpSF.Text, itemp1, Len(ListHelpSF.Text) - itemp1 + 1))
    ListHelpSF.Visible = Fals
    txtFields(11).SetFocus
End Sub

Private Sub ListHelpSF_LostFocus()
SFlisthelpVisible = False
End Sub
'业务地区输入辅助下拉框添加记录
Private Sub ListHelpYwdq_Click()
itemp1 = InStr(ListHelpYwdq.Text, " ")
txtFields(13).Text = Trim(Mid(ListHelpYwdq.Text, itemp1, Len(ListHelpYwdq.Text) - itemp1 + 1))
ListHelpYwdq.Visible = False
 txtFields(12).SetFocus
End Sub
'综合地区输入辅助下拉框添加记录
Private Sub ListHelpZhDq_Click()
itemp1 = InStr(ListHelpZhDq.Text, " ")
txtFields(18).Text = Trim(Mid(ListHelpZhDq.Text, itemp1, Len(ListHelpZhDq.Text) - itemp1 + 1))
ListHelpZhDq.Visible = False
txtFields(19).SetFocus
End Sub
'单位编码输入辅助下拉框显示
Private Sub txtFields_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
'On Error GoTo errorshow
If Index = 1 And txtFields(1) <> "" Then
      ListHelpDwbm.Visible = True
      rsKhbm.Filter = "最新标志='1' and 单位编码 like '" & Trim(txtFields(1).Text) & "%'"
      rsKhbm.Requery
   If rsKhbm.RecordCount > 0 Then
      rsKhbm.MoveFirst
      If (KeyCode >= 48 And KeyCode <= 57) Or (KeyCode >= 96 And KeyCode <= 105) Then
        ListHelpDwbm.Clear
        For i = 1 To rsKhbm.RecordCount
             ListHelpDwbm.AddItem rsKhbm(0) & Space(12 - Len(rsKhbm(0))) & rsKhbm(1)
             rsKhbm.MoveNext
        Next
      End If
   End If
End If
If KeyCode = 13 Then SendKeys "{tab}"
If (KeyCode = 27) Then ListHelpBM.Visible = False
Exit Sub
errorshow:
MsgBox Err.Description
Exit Sub
kperr:
   MsgBox Err.Description
End Sub

Private Sub txtFields_GotFocus(Index As Integer)
If Index = 13 Then
         ListHelpYwdq.Move txtFields(Index).Left, txtFields(Index).Top + txtFields(Index).Height
        ListHelpYwdq.Visible = True
        rsDqbm1.Requery
    If rsDqbm1.RecordCount > 0 Then
        rsDqbm1.MoveFirst
        ListHelpYwdq.Clear
        For i = 1 To rsDqbm1.RecordCount
             ListHelpYwdq.AddItem rsDqbm1(0) & Space(4 - Len(rsDqbm1(0))) & rsDqbm1(1)
             rsDqbm1.MoveNext
        Next
     End If
End If
If Index = 12 Then
        ListHelpSF.Move txtFields(Index).Left, txtFields(Index).Top + txtFields(Index).Height
        ListHelpSF.Visible = True
        rsSFBM1.Requery
    If rsSFBM1.RecordCount > 0 Then
        rsSFBM1.MoveFirst
        ListHelpSF.Clear
        For i = 1 To rsSFBM1.RecordCount
             ListHelpSF.AddItem rsSFBM1(0) & Space(4 - Len(rsSFBM1(0))) & rsSFBM1(1)
             rsSFBM1.MoveNext
        Next
     End If
End If
If Index = 11 Then
     ListHelpBM.Move txtFields(Index).Left, txtFields(Index).Top + txtFields(Index).Height
     ListHelpBM.Visible = True
     rsBmbm1.Requery
   If rsBmbm1.RecordCount > 0 Then
        rsBmbm1.MoveFirst
        ListHelpBM.Clear
        For i = 1 To rsBmbm1.RecordCount
             ListHelpBM.AddItem rsBmbm1(0) & Space(4 - Len(rsBmbm1(0))) & rsBmbm1(1)
             rsBmbm1.MoveNext
        Next
     End If
 End If
If Index = 18 Then
     ListHelpZhDq.Move txtFields(18).Left, txtFields(18).Top + txtFields(18).Height
      ListHelpZhDq.Visible = True
      rsDq1.Requery
  If rsDq1.RecordCount > 0 Then
      ListHelpZhDq.Clear
      rsDq1.MoveFirst
      For i = 1 To rsDq1.RecordCount
           ListHelpZhDq.AddItem rsDq1(0) & Space(4 - Len(rsDq1(0))) & rsDq1(1)
           rsDq1.MoveNext
           Next
  End If
End If
If Index = 1 Then
       ListHelpDwbm.Move txtFields(Index).Left, txtFields(Index).Height + txtFields(Index).Top
       ListHelpDwbm.Visible = True
End If
End Sub

Private Sub txtFields_LostFocus(Index As Integer)
 If Index = 1 Then ListHelpDwbm.Visible = False
 If Index = 13 Then ListHelpYwdq.Visible = False
 If (Index = 11) Then ListHelpBM.Visible = False
 If (Index = 12) Then ListHelpSF.Visible = False
 If Index = 18 Then ListHelpZhDq.Visible = False
End Sub