frmkhinfo.frm

一套简易的MIS系统。带SQLServer数据库。供参考。

   End
End
Attribute VB_Name = "frmKHInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmbState_KeyPress(KeyAscii As Integer)
    
    If KeyAscii = vbKeyReturn Then
        txtCust(5).SetFocus
        SendKeys "{Home}+{End}"
        Exit Sub
    End If
    
End Sub

Private Sub cmbType_KeyPress(KeyAscii As Integer)
    
    If KeyAscii = vbKeyReturn Then
        cmbState.SetFocus
        SendKeys "%{Down}"
        Exit Sub
    End If
    
End Sub

Private Sub cmdBack_Click()
    
    '返回
    tBackMain Me
    
End Sub

Private Sub cmdOK_Click()
    
    Dim iIndex              As Integer
    
    On Error GoTo ErrInfo
    
    For iIndex = 0 To 2
        If txtCust(iIndex).Text = "" Then
            MsgBox "错误的基础数据！", vbInformation, "提示："
            txtCust(iIndex).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        End If
    Next
    With uShareInfo
        .strCode = txtCust(0).Text
        .strName = txtCust(1).Text
        .strShare = txtCust(2).Text
        .strShare1 = txtCust(3).Text
        .strShare2 = txtCust(4).Text
        .strShare3 = txtCust(5).Text
        .strType = rtxtMemo.Text
        .dInDate = Format(InDate.Value, "YYYY-MM-DD")
        .intFlag = tString(Trim(cmbType.Text), "[", "]", 0)
        .intFlag1 = tString(Trim(cmbState.Text), "[", "]", 0)
    End With
    If tCSTInfo(uShareInfo, iAdd_Update) = False Then
        MsgBox "数据操作失败！", vbInformation, "提示："
        Exit Sub
    End If
    MsgBox "数据操作成功！", vbInformation, "提示："
    For iIndex = 0 To txtCust.Count - 1
        txtCust(iIndex).Text = ""
    Next
    rtxtMemo.Text = ""
    iAdd_Update = 0
    '显示表头
    getCustHead
    '显示数据
    getCustData ""
    If txtCust(0).Locked = True Then txtCust(0).Locked = False
    txtCust(0).SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
ErrInfo:
    MsgBox Err.Description, vbInformation, "提示："
    
End Sub

Private Sub cmdQuery_Click()
    
    getCustData Trim(txtCust(0).Text)
    
End Sub

Private Sub Command1_Click()
    
    Call cmdOK_Click
    
End Sub

Private Sub Form_Load()

    '计算窗体显示位置
    tFormSpace frmMain, Me, uWindows
    '显示表头
    getCustHead
    '显示数据
    getCustData ""
    
    InDate.Value = Format(tServerDate, "YYYY年MM月DD日")
    '显示基本信息
    iAdd_Update = 0
    With cmbType
        .Clear
        .AddItem "客户[0]"
        .AddItem "临时客户[1]"
        .Text = .List(0)
    End With
    '显示基本信息
    With cmbState
        .Clear
        .AddItem "正常[0]"
        .AddItem "停用[1]"
        .Text = .List(0)
    End With
    
End Sub

Private Sub inDate_KeyDown(KeyCode As Integer, Shift As Integer)
    
    If KeyCode = vbKeyReturn Then
        cmbType.SetFocus
        SendKeys "%{Down}"
        Exit Sub
    End If
    
End Sub

Private Sub lstKHInfo_DblClick()
    
    iAdd_Update = 1
    txtCust(0).Text = lstKHInfo.SelectedItem.SubItems(1)
    txtCust(1).Text = lstKHInfo.SelectedItem.SubItems(2)
    txtCust(2).Text = lstKHInfo.SelectedItem.SubItems(3)
    txtCust(3).Text = lstKHInfo.SelectedItem.SubItems(4)
    txtCust(4).Text = lstKHInfo.SelectedItem.SubItems(5)
    txtCust(5).Text = lstKHInfo.SelectedItem.SubItems(9)
    cmbType.Text = lstKHInfo.SelectedItem.SubItems(6)
    InDate.Value = Format(lstKHInfo.SelectedItem.SubItems(7), "YYYY年MM月DD日")
    cmbState.Text = lstKHInfo.SelectedItem.SubItems(8)
    rtxtMemo.Text = lstKHInfo.SelectedItem.SubItems(10)
    txtCust(0).Locked = True
    txtCust(1).SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
    
End Sub

Private Sub rtxtMemo_KeyPress(KeyAscii As Integer)
    
    If KeyAscii = vbKeyReturn Then
        cmdOK.SetFocus
        Exit Sub
    End If
    
End Sub

Private Sub txtCust_GotFocus(Index As Integer)
    
    txtCust(Index).BackColor = &HC0FFC0
    txtCust(Index).ForeColor = vbRed
    
End Sub

Private Sub txtCust_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
        Case vbKeyDown
            If Index = txtCust.Count - 1 Then Exit Sub
            txtCust(Index + 1).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case vbKeyUp
            If Index = 0 Then Exit Sub
            txtCust(Index - 1).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtCust_KeyPress(Index As Integer, KeyAscii As Integer)
    
    Select Case KeyAscii
        Case vbKeyReturn
            Select Case Index
                Case 0
                    If txtCust(Index).Text = "" Then
                        If MsgBox("系统将自动生成最大编码？", vbInformation + vbYesNo, "提示：") = vbYes Then
                            txtCust(Index).Text = tKHBigCode("tbCCCust", "Cust_ID")
                            txtCust(Index + 1).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        Else
                            txtCust(Index).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        End If
                    End If
                    If tWhileCode("tbCCCust", "Cust_ID", Format(Trim(txtCust(Index).Text), "00000000")) = False Then
                        MsgBox "编码重复！请检查您的输入是否正确？", vbInformation, "提示："
                        txtCust(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    Else
                        txtCust(Index).Text = Format(txtCust(Index).Text, "00000000")
                        txtCust(Index + 1).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                Case 1
                    If Trim(txtCust(Index).Text) = "" Or Len(Trim(txtCust(Index).Text)) = 0 Then
                        MsgBox Err.Description, vbInformation, "提示："
                        txtCust(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    If tWhileCode("tbCCCust", "Cust_Name", Trim(txtCust(Index).Text)) = False Then
                        MsgBox "信息重复！请检查您的输入是否正确？", vbInformation, "提示："
                        txtCust(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    txtCust(Index + 1).SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                Case 2
                    txtCust(Index + 1).SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                Case 3
                    txtCust(Index + 1).SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                Case 4
                    InDate.SetFocus
                    Exit Sub
                Case 5
                    rtxtMemo.SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
            End Select
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtCust_LostFocus(Index As Integer)

    txtCust(Index).BackColor = vbWhite
    txtCust(Index).ForeColor = vbBlack
    
End Sub

'显示表头
Private Sub getCustHead()
    
    With lstKHInfo
        .ListItems.Clear
        .FullRowSelect = True
        .GridLines = True
        .View = lvwReport
        .LabelEdit = lvwManual
        With .ColumnHeaders
            .Clear
            .Add , , "@", 0
            .Add , , "客户编码", 1600
            .Add , , "客户名称", 1400
            .Add , , "客户地址", 1800
            .Add , , "联系人", 1200
            .Add , , "电话", 1400
            .Add , , "客户类型", 1200
            .Add , , "录入日期", 1200
            .Add , , "客户状态", 1200
            .Add , , "输入码", 1200
            .Add , , "备注", 1200
        End With
    End With
    
End Sub

'显示数据
Private Function getCustData(strInfo As String)

    Dim rsTemp            As New ADODB.Recordset
    Dim iIndex            As Integer
    Dim strSQL            As String
    strSQL = " Where Cust_id Like '" & strInfo & "%' Or Cust_name Like '" & strInfo & "%' Or Cust_zjm Like '" & strInfo & "%' Or " _
                & " Cust_Addres Like '" & strInfo & "%' Or Link_man Like '" & strInfo & "%' Or Cust_tel Like '" & strInfo & "%' Or Remark Like '" & strInfo & "%' "
    Set rsTemp = DBCN.Execute("Select Cust_id,Cust_name,Cust_zjm,Cust_Addres,Link_man,Cust_tel,Remark,Cust_sort,Oper_date," _
                            & " Instate from tbCCCust " & strSQL & " Order by Cust_ID ")

    If rsTemp.EOF = False Then
        iIndex = 1
        lstKHInfo.ListItems.Clear
        Do Until rsTemp.EOF
            lstKHInfo.ListItems.Add iIndex, , iIndex
            With lstKHInfo.ListItems(iIndex)
                .SubItems(1) = IIf(IsNull(rsTemp.Fields("Cust_ID")), "", rsTemp.Fields("Cust_ID"))
                .SubItems(2) = IIf(IsNull(rsTemp.Fields("Cust_name")), "", rsTemp.Fields("Cust_name"))
                .SubItems(3) = IIf(IsNull(rsTemp.Fields("Cust_Addres")), "", rsTemp.Fields("Cust_Addres"))
                .SubItems(4) = IIf(IsNull(rsTemp.Fields("Link_man")), "", rsTemp.Fields("Link_man"))
                .SubItems(5) = IIf(IsNull(rsTemp.Fields("Cust_tel")), "", rsTemp.Fields("Cust_tel"))
                If rsTemp.Fields("Cust_sort") = 0 Then
                    .SubItems(6) = "客户[" & rsTemp.Fields("Cust_sort") & "]"
                Else
                    .SubItems(6) = "临时客户[" & rsTemp.Fields("Cust_sort") & "]"
                End If
                .SubItems(7) = IIf(IsNull(rsTemp.Fields("Oper_date")), "", rsTemp.Fields("Oper_date"))
                If rsTemp.Fields("Instate") = 0 Then
                    .SubItems(8) = "正常[" & rsTemp.Fields("Instate") & "]"
                Else
                    .SubItems(8) = "停用[" & rsTemp.Fields("Instate") & "]"
                End If
                .SubItems(9) = IIf(IsNull(rsTemp.Fields("Cust_zjm")), "", rsTemp.Fields("Cust_zjm"))
                .SubItems(10) = IIf(IsNull(rsTemp.Fields("Remark")), "", rsTemp.Fields("Remark"))
                Dim iRedList                 As Integer
                For iRedList = 1 To lstKHInfo.ColumnHeaders.Count - 1
                    If rsTemp.Fields("Instate") = 1 Then
                        .ListSubItems(iRedList).ForeColor = vbRed
                    End If
                Next
            End With
            rsTemp.MoveNext
            iIndex = iIndex + 1
        Loop
    Else
        MsgBox "没有符合条件的信息!", vbInformation, "提示："
    End If
    
End Function