frmmerch.frm

超市销售管理系统 4) 文档里面有完整的需求说明书

'注：此代码禁止用于商业用途。有修改者发我一份，谢谢！
'---------------- 开源世界，你我更进步 ----------------

Dim strCurSQL1 As String, strCurSQL2 As String, strCurSQL3 As String
Dim lngCurPageSize As Long
Dim NoChangeSQL As Boolean
Public xChangeItem As String

Private Sub cboFactory_Click()
    ChangeSQL
End Sub

Private Sub ChangeSQL()
    If NoChangeSQL Then Exit Sub
    strCurSQL2 = "Where "
    If cboFactory.ListIndex > 0 Then strCurSQL2 = strCurSQL2 & "FactoryName='" & cboFactory.Text & "' and "
    If cboProvide.ListIndex > 0 Then strCurSQL2 = strCurSQL2 & "ProvideName='" & cboProvide.Text & "' and "
    Select Case cboState.ListIndex
    Case 1
        strCurSQL2 = strCurSQL2 & "SalesProPrice is not null and SalesProDateS<='" & Date & "' and SalesProDateE>='" & Date & "' and "
    Case 2
        strCurSQL2 = strCurSQL2 & "MerchNum<=CautionNum and "
    Case 3
        strCurSQL2 = strCurSQL2 & "AllowSale=0 and "
    End Select
    LoadMerchSQL strCurSQL1 & strCurSQL2 & strCurSQL3, 1, lngCurPageSize
End Sub

Private Sub cboPage_Click()
    If cboPage.Enabled = False Then Exit Sub
    If cboPage.ListIndex = 0 Then
        LoadMerchSQL strCurSQL1 & strCurSQL2 & strCurSQL3, 1
    Else
        LoadMerchSQL strCurSQL1 & strCurSQL2 & strCurSQL3, cboPage.ListIndex, lngCurPageSize
    End If
End Sub

Private Sub cboProvide_Click()
    ChangeSQL
End Sub

Private Sub cboState_Click()
    ChangeSQL
End Sub

Private Sub cmdAdd_Click()
    If lstFactory.ListCount <= 0 Or lstProvide.ListCount <= 0 Then
        If MsgBox("添加商品之前，您必须分别拥有至少一个的厂商或供货商。" & vbCrLf & vbCrLf & "现在马上添加厂商或供货商？", vbInformation + vbOKCancel) = vbOK Then
            frmMain.cmdLeft_Click (4)
        End If
        Exit Sub
    End If
    xChangeItem = ""
    frmMerchItem.Show 1
End Sub

Private Sub cmdASale_Click(Index As Integer)
'On Error GoTo aaaa
    Dim i As Long, j As Long
    j = 0
    For i = 1 To List1.ListItems.Count
        If List1.ListItems(i).Selected = True Then j = j + 1
    Next
    If j = 0 Then
        MsgBox "没有选中任何商品。", vbInformation
        Exit Sub
    End If
    If MsgBox("确定" & IIf(Index = 0, "禁止", "允许") & "销售这 " & j & " 个商品吗？", vbInformation + vbOKCancel + vbDefaultButton2) = vbCancel Then Exit Sub
    '
    For i = List1.ListItems.Count To 1 Step -1
        If List1.ListItems(i).Selected = True Then
            cnMain.Execute "UpDate [MerchInfo] Set AllowSale=" & Index & "  Where BarCode='" & List1.ListItems(i).SubItems(2) & "'"
        End If
    Next
    cboPage_Click
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub cmdClose_Click()
    ShowRight False
End Sub

Public Sub ShowRight(ByVal b As Boolean)
    picRight.Visible = b
    cmdSearch.Enabled = Not b
    SaveINI "Main", "MerchBar", IIf(b = True, "", "n")
    Form_Resize
End Sub

Private Sub cmdDel_Click()
On Error GoTo aaaa
    Dim i As Long, j As Long
    j = 0
    For i = 1 To List1.ListItems.Count
        If List1.ListItems(i).Selected = True Then j = j + 1
    Next
    If j = 0 Then
        MsgBox "没有选中任何商品。", vbInformation
        Exit Sub
    End If
    If MsgBox("注意：此操作会同时删除商品的销售记录，进货记录和进货计划记录。" & vbCrLf & vbCrLf & "确定删除选中的 " & j & " 个商品吗？", vbInformation + vbOKCancel + vbDefaultButton2) = vbCancel Then Exit Sub
    
    For i = List1.ListItems.Count To 1 Step -1
        If List1.ListItems(i).Selected = True Then
            cnMain.Execute "Delete From [MerchInfo] Where BarCode='" & List1.ListItems(i).SubItems(2) & "'"
            List1.ListItems.Remove i
        End If
    Next
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub cmdEdit_Click()
On Error GoTo aaaa
    Dim Item As ListItem
    Set Item = List1.SelectedItem
    xChangeItem = Item.SubItems(2)
    frmMerchItem.Show 1
aaaa:
End Sub

Private Sub cmdFind_Click()
    Dim b As Boolean
    b = False
    strCurSQL2 = "Where "
    txtBarCode.Text = Trim(txtBarCode.Text)
    txtName.Text = Trim(txtName.Text)
    txtPrice.Text = Trim(txtPrice.Text)
    If txtBarCode.Text <> "" Then strCurSQL2 = strCurSQL2 & "BarCode='" & txtBarCode.Text & "' and ": b = True
    If txtName.Text <> "" Then strCurSQL2 = strCurSQL2 & "MerchName like '%" & txtName.Text & "%' and ": b = True
    If txtPrice.Text <> "" Then strCurSQL2 = strCurSQL2 & "MerchPrice=" & txtPrice.Text & " and ": b = True
    If b Then
        NoChangeSQL = True
        cboFactory.ListIndex = 0
        cboProvide.ListIndex = 0
        cboState.ListIndex = 0
        NoChangeSQL = False
        LoadMerchSQL strCurSQL1 & strCurSQL2 & strCurSQL3, 1, lngCurPageSize
    Else
        MsgBox "请指定条件!", vbInformation
    End If
    txtBarCode.SetFocus
End Sub

Private Sub cmdFirst_Click()
    cboPage.ListIndex = 1
End Sub

Private Sub cmdLast_Click()
    cboPage.ListIndex = cboPage.ListCount - 1
End Sub

Private Sub cmdNext_Click()
    cboPage.ListIndex = cboPage.ListIndex + 1
End Sub

Private Sub cmdPre_Click()
    cboPage.ListIndex = cboPage.ListIndex - 1
End Sub

Private Sub cmdSearch_Click()
    ShowRight True
    txtBarCode.SetFocus
End Sub

Private Sub Command1_Click()
    PopupMenu mnuMerch
End Sub

Private Sub cmdStock_Click()
On Error GoTo aaaa
    Dim i As Long, j As Long
    j = 0
    For i = 1 To List1.ListItems.Count
        If List1.ListItems(i).Selected = True Then j = j + 1
    Next
    If j = 0 Then
        MsgBox "没有选中任何商品。", vbInformation
        Exit Sub
    End If
    
    Dim rtn As String
    Do
        rtn = InputBox("请设定一个计划进货的日期", , Format(Date, "yyyy-mm-dd"))
        rtn = Trim(rtn)
        If rtn = "" Then
            Exit Sub
        Else
            If IsDate(rtn) = False Then
                MsgBox "不是一个有效的日期。", vbCritical
            Else
                Exit Do
            End If
        End If
    Loop
    
    Dim Item As ListItem
    With frmPlanStock
        For i = 1 To List1.ListItems.Count
            If List1.ListItems(i).Selected = True Then
                Set Item = .List1.ListItems.Add(, List1.ListItems(i).Key, List1.ListItems(i).Text, , 1)
                Item.SubItems(1) = List1.ListItems(i).Tag
                Item.SubItems(2) = rtn
                Item.SubItems(3) = List1.ListItems(i).SubItems(3)
            End If
        Next
        .Show 1
    End With
    
Exit Sub
aaaa:
    MsgBox Err.Description, vbCritical
End Sub

Private Sub Form_Load()
    Me.WindowState = 2
    imgIcon.Picture = frmMain.cmdLeft(1).Picture
    lngCurPageSize = 50
    '加载商品
    strCurSQL1 = "SELECT MerchID,MerchName,MerchPrice,BarCode,MerchNum,CautionNum,PlanNum,SalesProPrice,SalesProDateS,SalesProDateE,AllowAbate,AllowSale,Factory.FactoryName,Provide.ProvideName From MerchInfo, Provide, Factory "
    strCurSQL2 = "Where "
    strCurSQL3 = "MerchInfo.FactoryID = Factory.FactoryID And MerchInfo.ProvideID = Provide.ProvideID order by MerchID Desc"
    LoadMerchSQL strCurSQL1 & strCurSQL2 & strCurSQL3, 1, lngCurPageSize
    '加载厂商
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    cboFactory.AddItem "[全部]"
    rs.Open "Select FactoryID,FactoryName From Factory order by FactoryID Desc", cnMain, 1, 1
    If Not rs.EOF Then
        Do Until rs.EOF
            cboFactory.AddItem rs("FactoryName")
            lstFactory.AddItem rs("FactoryID")
            rs.MoveNext
        Loop
    End If
    '加载供货商
    cboProvide.AddItem "[全部]"
    Set rs = New ADODB.Recordset
    rs.Open "Select ProvideID,ProvideName From Provide order by ProvideID Desc", cnMain, 1, 1
    If Not rs.EOF Then
        Do Until rs.EOF
            cboProvide.AddItem rs("ProvideName")
            lstProvide.AddItem rs("ProvideID")
            rs.MoveNext
        Loop
    End If
    '加载状态列表
    cboState.AddItem "[正常]"
    cboState.AddItem "促销商品"
    cboState.AddItem "缺货报警"
    cboState.AddItem "禁止销售"
    '高级
    If GetINI("Main", "MerchBar") = "n" Then
        cmdSearch.Enabled = True
        picRight.Visible = False
    End If
End Sub

Public Sub LoadMerchSQL(ByVal sql As String, Optional ByVal lngPageIndex As Long = 1, Optional ByVal lngPageSize As Long = -1)
    Dim Item As ListItem
    Dim i&, lngPageCount&
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    rs.Open sql, cnMain, 1, 1
    List1.ListItems.Clear
    List1.Sorted = False
    If lngPageSize = -1 Then
        rs.PageSize = rs.RecordCount + 1
    Else
        rs.PageSize = lngPageSize
    End If
    If rs.EOF = False Then rs.AbsolutePage = lngPageIndex
    lngPageCount = Int(rs.RecordCount / rs.PageSize) + IIf(rs.RecordCount Mod rs.PageSize = 0, 0, 1)
    cmdFirst.Enabled = (lngPageIndex > 1)
    cmdPre.Enabled = (lngPageIndex > 1)
    cmdNext.Enabled = (lngPageIndex < lngPageCount)
    cmdLast.Enabled = (lngPageIndex < lngPageCount)
    cboPage.Enabled = False
    If cboPage.ListCount <> lngPageCount Then
        cboPage.Clear
        cboPage.AddItem "[全部]"
        If lngPageSize = -1 Then
            cboPage.AddItem "[分页]"
            cboPage.ListIndex = 0
        Else
            For j = 1 To lngPageCount
                cboPage.AddItem j
            Next
            cboPage.ListIndex = lngPageIndex
        End If
    End If
    cboPage.Enabled = True
    If Not rs.EOF Then
        Do While Not rs.EOF And i < rs.PageSize
            Set Item = List1.ListItems.Add(, "k" & rs("MerchID"), rs("MerchName"), , 1)
            With Item
                .SubItems(1) = rs("MerchPrice")
                .SubItems(2) = rs("BarCode")
                .SubItems(3) = rs("MerchNum")
                .SubItems(4) = IIf(CLng(rs("AllowAbate")) = 1, "允许", "")
                .SubItems(5) = GetMerchState(Item, CLng(rs("MerchNum")), CLng(rs("CautionNum")), rs("SalesProPrice") & "", rs("SalesProDateS") & "", rs("SalesProDateE") & "", CLng(rs("AllowSale")))
                .SubItems(6) = rs("FactoryName")
                .SubItems(7) = rs("ProvideName")
                .Tag = rs("PlanNum")
            End With
            rs.MoveNext
            i = i + 1
        Loop
    End If
    SetSB 2, "共 " & rs.RecordCount & " 条商品记录, 当前页 " & i & " 条."
End Sub

Public Function GetMerchState(ByVal Item As ListItem, ByVal MerchNum&, ByVal CautionNum&, ByVal SalesProPrice$, ByVal SalesProDateS$, ByVal SalesProDateE$, ByVal AllowSale&) As String
On Error GoTo aaaa
    Dim d1 As Date, d2 As Date, j1 As Long, j2 As Long
    If AllowSale = 0 Then
        GetMerchState = "禁止"
        Item.ForeColor = 9372343
        Item.SmallIcon = 3
    Else
        If SalesProPrice <> "" Then
            d1 = CDate(SalesProDateS)
            d2 = CDate(SalesProDateE)
            j1 = DateDiff("d", Date, d1)
            j2 = DateDiff("d", Date, d2)
            If j1 <= 0 And j2 >= 0 Then
                If MerchNum <= CautionNum Then
                    GetMerchState = "促/警": Item.ForeColor = vbRed: Item.SmallIcon = 2
                Else
                    GetMerchState = "促销": Item.ForeColor = vbBlue: Item.SmallIcon = 4
                End If
                Exit Function
            End If
        Else
            If MerchNum <= CautionNum Then GetMerchState = "报警": Item.ForeColor = vbRed: Item.SmallIcon = 2: Exit Function
        End If
        GetMerchState = ""
        Item.ForeColor = 0
        Item.SmallIcon = 1
    End If
Exit Function
aaaa:
    GetMerchState = ""
End Function

Private Sub Form_Resize()
On Error Resume Next
    List1.Width = Width / 15 - IIf(picRight.Visible, 222, 40)
    List1.Height = Height / 15 - 116
    picRight.Left = Width / 15 - 202
    picRight.Height = List1.Height + 5
    PicTop.Width = Width / 15 - 16
    Cls
    Line (2, 2)-(Width / 15 - 14, Height / 15 - 29), 10921638, B
End Sub

Private Sub List1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
    With List1
        If (ColumnHeader.Index - 1) = .SortKey Then
            .SortOrder = 1 - .SortOrder
            .Sorted = True
        Else
            .Sorted = False
            .SortOrder = 0
            .SortKey = ColumnHeader.Index - 1
            .Sorted = True
        End If
    End With
End Sub

Private Sub List1_DblClick()
On Error GoTo aaaa
    Dim j As Long
    j = List1.SelectedItem.Index
    cmdEdit_Click
aaaa:
End Sub

Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo aaaa
    
    If KeyCode = vbKeyDelete Then
        j = List1.SelectedItem.Index
        cmdDel_Click
    End If
    If KeyCode = vbKeyA And Shift = 2 Then
        For j = 1 To List1.ListItems.Count
            List1.ListItems(j).Selected = True
        Next
    End If
aaaa:
End Sub

Private Sub txtBarCode_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then cmdFind_Click
End Sub