frmxsfs1.frm

vb程序设计仁宇人份管理

         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   180
      Index           =   2
      Left            =   360
      TabIndex        =   15
      Top             =   855
      Width           =   1170
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      Caption         =   "销售方式名称:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   180
      Index           =   1
      Left            =   360
      TabIndex        =   13
      Top             =   525
      Width           =   1170
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      Caption         =   "销售方式编码:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   180
      Index           =   0
      Left            =   360
      TabIndex        =   0
      Top             =   210
      Width           =   1170
   End
End
Attribute VB_Name = "frmXSFSbm"
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 rsXsfsbm As New Recordset
'对CELL的处理
Private Sub usSetCell()
    '刷新
    Cell1.DoResetContent
    '打开文件
    Cell1.DoOpenFile App.Path & "\cell\xsfs.cll"
    '确定CELL的行数
    Cell1.rows = adoPrimaryRS.RecordCount + 1
    Cell1.DoSetUnScrollRow 0, 0
    adoPrimaryRS.Filter = "销售种类=0"

    Cell1.DoSetCellString 0, 1, "自 销"
    For i = 1 To adoPrimaryRS.RecordCount
        Cell1.DoSetCellString 1, i, adoPrimaryRS(0)
        Cell1.DoSetCellString 2, i, adoPrimaryRS(1)
        Cell1.DoSetCellString -1, i, adoPrimaryRS.Bookmark
        adoPrimaryRS.MoveNext
    Next
    Cell1.DoJoinCells 0, 1, 0, adoPrimaryRS.RecordCount
    Cell1.DoSetCellAlignment 0, 1, 36
    adoPrimaryRS.Filter = "销售种类=1"
    Cell1.DoSetCellString 0, i, "促 销"
    For j = i To adoPrimaryRS.RecordCount + i - 1
        Cell1.DoSetCellString 1, j, adoPrimaryRS(0)
        Cell1.DoSetCellString 2, j, adoPrimaryRS(1)
        Cell1.DoSetCellString -1, j, adoPrimaryRS.Bookmark
        adoPrimaryRS.MoveNext
    Next
    Cell1.DoJoinCells 0, i, 0, adoPrimaryRS.RecordCount + i - 1
    Cell1.DoSetCellAlignment 0, i, 36
    Cell1.GridReadOnly = True
    adoPrimaryRS.Filter = ""
    adoPrimaryRS.MoveFirst
End Sub

Private Sub Cell1_OnRowChange(ByVal oldrow As Long, ByVal newrow As Long)
    Cell1.DoGetCellData -1, newrow, intrecno
    If Not IsEmpty(intrecno) Then adoPrimaryRS.Bookmark = Val(intrecno)
End Sub
'查询
Private Sub cmdQuery_Click()
  Me.Hide
  frmXsfsbmcx.Show
End Sub

Private Sub ComboXszl_Click()
txtFields(2) = ComboXszl.ListIndex
End Sub
'保证双击查询窗口CELL切换到维护界面时当前记录的一致性
Private Sub Form_Activate()
  If Me.Tag <> "" Then
     adoPrimaryRS.MoveFirst
     adoPrimaryRS.Find ("销售方式编码 = '" & Me.Tag & "'")
  End If
End Sub

Private Sub Form_Load()
  Cell1.DoLogin "HOLLYWAY", 294, "1404900178057C05E403710A870A"
  Set adoPrimaryRS = New Recordset
  adoPrimaryRS.Open "select 销售方式编码,销售方式,销售种类 from XSFS order by 销售方式编码", dblgjx, adOpenStatic, adLockOptimistic
 
  rsXsfsbm.Open "select 销售方式编码  from XSFS order by 销售方式编码", dblgjx, adOpenStatic, adLockOptimistic
 
  Dim oText As TextBox
  '绑定文本框到数据提供者
  For Each oText In Me.txtFields
    Set oText.DataSource = adoPrimaryRS
  Next
  Set txtFields(0).DataSource = Nothing
  Set txtXsfs.DataSource = adoPrimaryRS
  usSetCell
  mbDataChanged = False
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
  If adoPrimaryRS.State = adStateOpen Then adoPrimaryRS.Close
  If rsXsfsbm.State = adStateOpen Then rsXsfsbm.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 显示当前记录位置
On Error GoTo mcerr

  lblStatus.Caption = "第 " & CStr(adoPrimaryRS.AbsolutePosition) & " 条记录"
  If Not (adoPrimaryRS.BOF Or adoPrimaryRS.EOF) Then ComboXszl.ListIndex = adoPrimaryRS(2)
  Exit Sub
mcerr:
   MsgBox Err.Description & "请您点［刷新］重新开始！"
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
  txtXsfs.Enabled = True
  txtFields(1).Enabled = True
  ComboXszl.Enabled = True
  With adoPrimaryRS
    If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
    End If
    .AddNew
    lblStatus.Caption = "添加记录"
    mbAddNewFlag = True
    SetButtons False
  End With
'  adoPrimaryRS(0) = ""
  txtXsfs.SelStart = 0
  txtXsfs.SelLength = 4
  txtXsfs.SelText = " -  "
  ComboXszl.ListIndex = 0
  txtFields(2) = 0
  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub
'修改
Private Sub cmdEdit_Click()
  On Error GoTo EditErr
  
  txtFields(1).Enabled = True
  ComboXszl.Enabled = True

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

EditErr:
  MsgBox Err.Description
End Sub
'取消操作
Private Sub cmdCancel_Click()
  On Error Resume Next
  
  txtXsfs.Enabled = False
  txtFields(1).Enabled = False
  ComboXszl.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 mbAddNewFlag Then
  rsXsfsbm.MoveFirst
     While Not rsXsfsbm.EOF
       If rsXsfsbm(0) = txtXsfs Then
          MsgBox "销售方式编码不可重复,请重新输入!", 48, "警告"
          txtXsfs.SetFocus
          Exit Sub
      End If
       rsXsfsbm.MoveNext
     Wend
   End If
  '批更新
  adoPrimaryRS.UpdateBatch adAffectAll
    
  txtXsfs.Enabled = False
  txtFields(1).Enabled = False
  ComboXszl.Enabled = False
  '写日志--添加
  If mbAddNewFlag Then
    strzc = "添加销售方式编码：" & txtXsfs & "。"
    dblgjx.Execute "insert into czrz values('" & user.DeptCode & user.UserCode & "','" & user.username & "','" & user.PcName & "','" & user.IP & "',sysdate,'" & strzc & "')"
  End If
  '写日志--修改
  If mbEditFlag Then
      strzc = "修改销售方式编码：" & txtXsfs & "。"
      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
  usSetCell
  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
  
  cmdQuery.Visible = bVal
  cmdClose.Visible = bVal

  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
End Sub