frmshopinfo.frm

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

   End
End
Attribute VB_Name = "frmShopInfo"
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
        rtxtMemo.SetFocus
        SendKeys "{Home}+{End}"
    End If
    
End Sub

Private Sub cmdOK_Click()
    
    Dim iIndex          As Integer
    
    On Error GoTo ErrInfo
    
    For iIndex = 0 To 1
        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
        .dInDate = Format(inDate.Value, "YYYY-MM-DD")
        .intFlag = tString(cmbState.Text, "[", "]", 0)
        .strType = rtxtMemo.Text
    End With
    
    If tShopInfo(uShareInfo, iAdd_Update) = False Then
        MsgBox "数据处理失败！", vbInformation, "提示："
        Exit Sub
    End If
    iAdd_Update = 0
    MsgBox "数据处理成功！", vbInformation, "提示："
    For iIndex = 0 To txtCust.Count - 1
        txtCust(iIndex).Text = ""
    Next
    '显示数据
    getShopData ""
    If txtCust(0).Locked = True Then txtCust(0).Locked = False
    txtCust(1).SetFocus
    SendKeys "{Home}+{End}"
    
    Exit Sub
ErrInfo:
    MsgBox Err.Description, vbInformation, "提示："
    
End Sub

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

Private Sub cmdUpdate_Click()
    
    Call cmdOK_Click
    
End Sub

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

Private Sub Form_Load()

    '计算窗体显示位置
    tFormSpace frmMain, Me, uWindows
    
    '显示基础数据
    With cmbState
        .Clear
        .AddItem "正常[0]"
        .AddItem "作废[1]"
        .Text = .List(0)
    End With
    inDate.Value = Format(tServerDate, "YYYY年MM月DD日")
    getShopHead
    getShopData ""
    

End Sub

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

Private Sub lstShopInfo_DblClick()
    
    On Error Resume Next
    iAdd_Update = 1
    txtCust(0).Text = lstShopInfo.SelectedItem.SubItems(1)
    txtCust(1).Text = lstShopInfo.SelectedItem.SubItems(2)
    txtCust(2).Text = lstShopInfo.SelectedItem.SubItems(3)
    txtCust(3).Text = lstShopInfo.SelectedItem.SubItems(4)
    txtCust(4).Text = lstShopInfo.SelectedItem.SubItems(5)
    inDate.Value = Format(lstShopInfo.SelectedItem.SubItems(6), "YYYY年MM月DD日")
    cmbState.Text = lstShopInfo.SelectedItem.SubItems(7)
    rtxtMemo.Text = lstShopInfo.SelectedItem.SubItems(8)
    txtCust(0).Locked = True
    txtCust(1).SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
    
End Sub

Private Sub rtxtMemo_KeyPress(KeyAscii As Integer)
    
    Select Case KeyAscii
        Case vbKeyReturn
            cmdOK.SetFocus
            Exit Sub
        Case Else
            Exit Sub
    End Select
    
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("tbCCProd", "Prod_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("tbCCProd", "Prod_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
                    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
            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 getShopHead()
    
    With lstShopInfo
        .ListItems.Clear
        .FullRowSelect = True
        .GridLines = True
        .View = lvwReport
        .LabelEdit = lvwManual
        With .ColumnHeaders
            .Clear
            .Add , , "@", 0
            .Add , , "供应商编号", 1400
            .Add , , "供应商名称", 1800
            .Add , , "供应商地址", 1800
            .Add , , "联系人", 1400
            .Add , , "联系电话", 1400
            .Add , , "状态", 1400
            .Add , , " 添加日期", 1400
            .Add , , "备注", 2000
        End With
    End With
    
End Sub

'显示数据
Private Function getShopData(strInfo As String)
    
    Dim iIndex               As Integer
    Dim strSQL               As String
    Dim rsTemp               As New ADODB.Recordset
    strSQL = " Where Prod_id Like '" & strInfo & "%' Or Prod_name Like '" & strInfo & "%' Or Prod_addres Like '" & strInfo & "%' Or " _
            & " Prod_tel Like '" & strInfo & "%' Or Link_man  Like '" & strInfo & "%' Or Remark Like '" & strInfo & "%' "
    Set rsTemp = DBCN.Execute("Select Prod_id,Prod_name,Prod_addres,Prod_tel,Link_man,Remark,Oper_id,Oper_date,Instate " _
                & " from tbCCProd " & strSQL & " Order By Prod_ID ")
    If rsTemp.EOF = False Then
        iIndex = 1
        lstShopInfo.ListItems.Clear
        Do Until rsTemp.EOF
            lstShopInfo.ListItems.Add iIndex, , iIndex
            With lstShopInfo.ListItems(iIndex)
                .SubItems(1) = IIf(IsNull(rsTemp.Fields("Prod_ID")), "", rsTemp.Fields("Prod_ID"))
                .SubItems(2) = IIf(IsNull(rsTemp.Fields("Prod_name")), "", rsTemp.Fields("Prod_name"))
                .SubItems(3) = IIf(IsNull(rsTemp.Fields("Prod_addres")), "", rsTemp.Fields("Prod_addres"))
                .SubItems(4) = IIf(IsNull(rsTemp.Fields("Prod_tel")), "", rsTemp.Fields("Prod_tel"))
                .SubItems(5) = IIf(IsNull(rsTemp.Fields("Link_man")), "", rsTemp.Fields("Link_man"))
                .SubItems(6) = IIf(IsNull(rsTemp.Fields("Oper_date")), "", rsTemp.Fields("Oper_date"))
                If rsTemp.Fields("Instate") = 0 Then
                    .SubItems(7) = "正常[" & rsTemp.Fields("Instate") & "]"
                Else
                    .SubItems(7) = "作废[" & rsTemp.Fields("Instate") & "]"
                End If
                .SubItems(8) = IIf(IsNull(rsTemp.Fields("Remark")), "", rsTemp.Fields("Remark"))
                Dim iRedList                 As Integer
                For iRedList = 1 To lstShopInfo.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