frmcarinfo.frm

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

        .strCode = txtCar(0).Text
        .strName = txtCar(1).Text
        .isgShare = CSng(txtCar(2).Text)
        .isgShare1 = CSng(txtCar(3).Text)
        .dInDate = Format(inDate.Value, "YYYY-MM-DD")
        .strShare = txtCar(4).Text
        .intFlag = tString(Trim(cmbState.Text), "[", "]", 0)
    End With
    
    If tCarInfo(uShareInfo, iAdd_Update) = False Then
        MsgBox "数据处理失败！", vbInformation, "提示："
        cmdOK.SetFocus
        Exit Sub
    End If
    iAdd_Update = 0
    MsgBox "数据处理完成！", vbInformation, "提示："
    getCarData ""
    For iIndex = 0 To txtCar.Count - 1
        txtCar(iIndex).Text = ""
    Next
    txtCar(0).Locked = False
    txtCar(0).SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
ErrInfo:
    MsgBox Err.Description, vbInformation, "提示："
    
End Sub

Private Sub cmdOpen_Click()
    
    With cdOpen
        .ShowOpen
    End With
    txtCar(4).Text = cdOpen.FileName
    inDate.SetFocus
    
End Sub

Private Sub cmdQuery_Click()
    
    On Error GoTo ErrInfo
    getCarData Trim(txtCar(0).Text)
    Exit Sub
ErrInfo:
    MsgBox Err.Description, vbInformation, "提示："
    
End Sub

Private Sub Form_Activate()
    
    txtCar(0).SetFocus
    SendKeys "{Home}+{End}"
    
End Sub

Private Sub Form_Load()

    '设置控件不显示
    lstInfo.Visible = False
    '计算窗体显示位置
    tFormSpace frmMain, Me, uWindows
    
    '初始化基本信息
    inDate.Value = Format(tServerDate, "YYYY年MM月DD日")
    iAdd_Update = 0
    With cmbState
        .Clear
        .AddItem "正常[0]"
        .AddItem "停用[1]"
        .Text = .List(0)
    End With
    
    '初始化
    getCarhead
    
    '数据
    getCarData ""
    
End Sub

Private Sub inDate_KeyDown(KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
        Case vbKeyReturn
            cmbState.SetFocus
            SendKeys "%{Down}"
            Exit Sub
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub lstCarInfo_DblClick()
    
    On Error Resume Next
    iAdd_Update = 1
    txtCar(0).Text = lstCarInfo.SelectedItem.SubItems(1)
    txtCar(1).Text = tString(lstCarInfo.SelectedItem.SubItems(2), "[", "]", 0)
    txtCar(2).Text = CSng(lstCarInfo.SelectedItem.SubItems(3))
    txtCar(3).Text = CSng(lstCarInfo.SelectedItem.SubItems(4))
    txtCar(4).Text = lstCarInfo.SelectedItem.SubItems(6)
    inDate.Value = Format(lstCarInfo.SelectedItem.SubItems(7), "YYYY年MM月DD日")
    If iPic <> 0 Then
        picCar.Picture = getPicture(lstCarInfo.SelectedItem.SubItems(1)).Picture
    Else
        picCar.Cls
    End If
    cmbState.Text = lstCarInfo.SelectedItem.SubItems(8)
    
    txtCar(0).Locked = True
    txtCar(1).SetFocus
    SendKeys "{Home}+{End}"
    
End Sub

Private Sub lstInfo_KeyPress(KeyAscii As Integer)
    
    Select Case KeyAscii
        Case vbKeyReturn
            txtCar(1).Text = lstInfo.SelectedItem.SubItems(1)
            strCustName = lstInfo.SelectedItem.SubItems(2)
            lstInfo.Visible = False
            txtCar(2).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case vbKeyEscape
            lstInfo.Visible = False
            txtCar(1).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtCar_GotFocus(Index As Integer)
    
    txtCar(Index).BackColor = &HC0FFC0
    txtCar(Index).ForeColor = vbRed
    
End Sub

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

Private Sub txtCar_KeyPress(Index As Integer, KeyAscii As Integer)
    
    Select Case KeyAscii
        Case vbKeyReturn
            Select Case Index
                Case 0
                    If txtCar(Index).Text = "" Then
                        If MsgBox("系统将自动生成最大编码？", vbInformation + vbYesNo, "提示：") = vbYes Then
                            txtCar(Index).Text = tBigCode("tbCCCar", "Car_ID")
                            txtCar(Index + 1).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        Else
                            txtCar(Index).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        End If
                    End If
                    If tWhileCode("tbCCCar", "Car_ID", Format(Trim(txtCar(Index).Text), "0000")) = False Then
                        MsgBox "编码重复！请检查您的输入是否正确？", vbInformation, "提示："
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    Else
                        txtCar(Index).Text = Format(txtCar(Index).Text, "0000")
                        txtCar(Index + 1).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                Case 1
                    If txtCar(Index).Text = "" Then
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    
                    Call getCustInfo(Trim(txtCar(Index).Text))
                    
                Case 2
                    If txtCar(Index).Text = "" Then
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    If IsNumeric(Trim(txtCar(Index).Text)) = False Then
                        MsgBox "只能是数字，包含了字符。请检查您的输入是否正确？", vbInformation, "提示："
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    txtCar(Index + 1).SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                Case 3
                    If txtCar(Index).Text = "" Then
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    If IsNumeric(Trim(txtCar(Index).Text)) = False Then
                        MsgBox "只能是数字，包含了字符。请检查您的输入是否正确？", vbInformation, "提示："
                        txtCar(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    txtCar(Index + 1).SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                Case 4
                    Call cmdOpen_Click
                    Exit Sub
            End Select
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtCar_LostFocus(Index As Integer)

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

'显示客户信息
Private Function getCustInfo(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 From tbCCCust " & strSQL & " " _
                            & " Order BY Cust_ID")
    If rsTemp.EOF = False Then
        With lstInfo
            .Top = txtCar(1).Top + txtCar(1).Height + 10
            .Left = txtCar(1).Left
            .Visible = True
            .View = lvwReport
            .FullRowSelect = True
            .GridLines = True
            .LabelEdit = lvwManual
            With .ColumnHeaders
                .Add , , "@", 0
                .Add , , "客户编号", 1400
                .Add , , "客户名称", 1800
                .Add , , "客户地址", 0
                .Add , , "联 系 人", 1400
                .Add , , "客户电话", 1000
                .Add , , "客户备注", 0
            End With
        End With
        iIndex = 1
        lstInfo.ListItems.Clear
        Do Until rsTemp.EOF
            lstInfo.ListItems.Add iIndex, , iIndex
            With lstInfo.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"))
                .SubItems(6) = IIf(IsNull(rsTemp.Fields("Remark")), "", rsTemp.Fields("Remark"))
            End With
            rsTemp.MoveNext
            iIndex = iIndex + 1
        Loop
        lstInfo.SetFocus
    Else
        MsgBox "没有相关的信息！请检查您的输入是否正确？", vbInformation, "提示："
        If lstInfo.Visible = True Then lstInfo.Visible = False
        txtCar(1).SetFocus
        SendKeys "{Home}+{End}"
    End If
    
End Function


'显示图片
Private Function getPicture(strInfo As String) As PictureBox
    
    Dim rsTemp           As New ADODB.Recordset
    
    Set rsTemp = DBCN.Execute("Select * from tbCCCar Where Car_ID='" & strInfo & "'")
    If rsTemp.EOF = False Then
        If rsTemp.RecordCount = 1 Then
            getPicture.Picture = rsTemp.Fields("Car_Photo")
            iPic = 1
        End If
    End If
    
End Function

'显示表头
Private Sub getCarhead()
    
    With lstCarInfo
        .ListItems.Clear
        .FullRowSelect = True
        .GridLines = True
        .LabelEdit = lvwManual
        .View = lvwReport
        With .ColumnHeaders
            .Clear
            .Add , , "@", 0
            .Add , , "车辆编码", 1200
            .Add , , "客户信息", 1800
            .Add , , "自    重", 1000
            .Add , , "载    重", 1000
            .Add , , "图片标志", 1000
            .Add , , "车辆文件", 1600
            .Add , , "录入日期", 1200
            .Add , , "状    态", 1200
        End With
    End With
    
End Sub

'显示数据
Private Function getCarData(strInfo As String)
    
    Dim rsTemp                As New ADODB.Recordset
    Dim iIndex                As Integer
    Dim strSQL                As String
    strSQL = " Where A.Car_id Like '" & strInfo & "%' Or A.Cust_id Like '" & strInfo & "%' Or B.Cust_name  Like '" & strInfo & "%' "
    Set rsTemp = DBCN.Execute("Select A.Car_id,A.Cust_id,A.Car_weigh,A.Car_carry,isnull(A.Car_photo,Car_photo) As Car_photo,A.Car_path,A.Oper_id,A.Oper_date,A.Instate,B.Cust_name " _
                            & " From tbCCCar A Left Join tbccCust B ON(A.Cust_id=B.Cust_id) " & strSQL & " Order By A.Car_ID ")
    If rsTemp.EOF = False Then
        iIndex = 1
        lstCarInfo.ListItems.Clear
        Do Until rsTemp.EOF
            lstCarInfo.ListItems.Add iIndex, , iIndex
            With lstCarInfo.ListItems(iIndex)
                .SubItems(1) = IIf(IsNull(rsTemp.Fields("Car_ID")), "", rsTemp.Fields("Car_ID"))
                .SubItems(2) = IIf(IsNull(rsTemp.Fields("Cust_name")), "", rsTemp.Fields("Cust_name")) & "[" & IIf(IsNull(rsTemp.Fields("Cust_id")), "", rsTemp.Fields("Cust_id")) & "]"
                .SubItems(3) = IIf(IsNull(rsTemp.Fields("Car_weigh")), 0, rsTemp.Fields("Car_weigh"))
                .SubItems(4) = IIf(IsNull(rsTemp.Fields("Car_carry")), 0, rsTemp.Fields("Car_carry"))
                If IsEmpty(rsTemp.Fields("Car_Photo")) = False Then
                    .SubItems(5) = "是"
                Else
                    .SubItems(5) = "否"
                End If
                .SubItems(6) = IIf(IsNull(rsTemp.Fields("Car_path")), "", rsTemp.Fields("Car_path"))
                .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
                Dim iRedList                 As Integer
                For iRedList = 1 To lstCarInfo.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, "提示："
        cmdQuery.SetFocus
        Exit Function
    End If
    
End Function