frmitemdisclistcard.frm

金算盘软件代码

                gclsBase.ExecSQL strSql
            Else
                ShowMsg hWnd, "商品“" & .TextMatrix(i, 1) & " " & .TextMatrix(i, 2) & "”" _
                    & "在" & msgGrid0.TextMatrix(mlngAccrossRow, 2) & "--" _
                    & msgGrid0.TextMatrix(mlngAccrossRow, 3) & "之间有两个贴息折扣率!", _
                    vbExclamation, Caption
                SSTab1.Tab = 0
                GoTo ErrHandle
            End If
        Next
        On Error GoTo 0
    End With
    SavePayPage = True
ErrHandle:
End Function

Private Function CheckPayDate(ByVal iRow As Integer) As Boolean
    Dim i As Integer
    
    If msgGrid0.RowHeight(iRow) = 0 Then
        CheckPayDate = True
        Exit Function
    End If
    CheckPayDate = False
    For i = 1 To msgGrid0.Rows - 1
        If msgGrid0.RowHeight(i) > 0 And i <> iRow Then
            If Not DateIsValid(iRow, , i) Then
                ShowMsg hWnd, "日期" & msgGrid0.TextMatrix(i, 2) & "--" & msgGrid0.TextMatrix(i, 3) _
                    & "与" & msgGrid0.TextMatrix(iRow, 2) & "--" & msgGrid0.TextMatrix(iRow, 3) _
                    & "有交叉!", vbExclamation, Caption
                SSTab1.Tab = 0
                Exit Function
            End If
        End If
    Next i
    CheckPayDate = True
End Function

Private Function DataIsValid(ByVal lngPayDiscID As Long, ByVal lngItemID As Long, ByVal strDateID As String) As Boolean
    Dim recDiscX As rdoResultset, strSql As String, strDiscID As String
    
    On Error GoTo ErrHandle
    DataIsValid = False
    strSql = "SELECT * FROM ItemPayDiscDetail WHERE lngItemID=" & lngItemID _
        & " AND lngItemPayDiscID<>" & lngPayDiscID
    Set recDiscX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recDiscX.EOF Then
        Do Until recDiscX.EOF
            strDiscID = strDiscID & "," & recDiscX("lngItemPayDiscID")
            recDiscX.MoveNext
        Loop
        strSql = "SELECT * FROM ItemPayDiscDate WHERE lngItemPayDiscID IN (" _
            & Mid(strDiscID, 2) & ") AND lngItemPayDiscDateID NOT IN (" & Mid(strDateID, 2) & ")"
        Set recDiscX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        With recDiscX
            Do Until .EOF
                If DateIsAccross(!strStartDate, !strEndDate) Then GoTo ErrHandle
                .MoveNext
            Loop
        End With
        recDiscX.Close
    Else
        recDiscX.Close
    End If
    DataIsValid = True
ErrHandle:
End Function

Private Function DateIsAccross(ByVal strStartDate As String, ByVal strEndDate As String) As Boolean
    Dim l As Long
    
    DateIsAccross = True
    With msgGrid0
        For l = 1 To .Rows - 1
            If (strStartDate >= .TextMatrix(l, 2) And strStartDate <= .TextMatrix(l, 3)) Or _
                (strEndDate >= .TextMatrix(l, 2) And strEndDate <= .TextMatrix(l, 3)) Then
                mlngAccrossRow = l
                Exit Function
            End If
        Next l
    End With
    DateIsAccross = False
End Function

Private Function SaveSalePage(ByVal lngID As Long) As Boolean
    Dim i As Long, strSql As String, recDisc As rdoResultset
    
    On Error GoTo ErrHandle
    SaveSalePage = False
    
    If mstrDiscName(1) = "" Then
        ShowMsg hWnd, "促销折扣的名称不能为空!", vbExclamation, Caption
        SSTab1.Tab = 1
        lstDisc(1).SetFocus
        GoTo ErrHandle
    ElseIf lngID = 0 Then
        strSql = "SELECT lngItemSaleDiscID FROM ItemSaleDisc WHERE strItemSaleDiscName" _
            & "='" & lstDisc(1).Text & "'"
        Set recDisc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recDisc.EOF Then
            lngID = recDisc("lngItemSaleDiscID")
        Else
            lngID = GetNewID("ItemSaleDisc")
            strSql = "INSERT INTO ItemSaleDisc(lngItemSaleDiscID,strItemSaleDiscName,strStartDate,strEndDate) " _
                 & "VALUES(" & lngID & ",'" & lstDisc(1).Text & "',' ',' ')"
            gclsBase.ExecSQL strSql
        End If
        recDisc.Close
    End If
    If dteDisc(0).Text = "" Then
        ShowMsg hWnd, "促销折扣的开始日期不能为空!", vbExclamation, Caption
        SSTab1.Tab = 1
        dteDisc(0).SetFocus
        GoTo ErrHandle
    End If
    If dteDisc(1).Text = "" Then
        ShowMsg hWnd, "促销折扣的结束日期不能为空!", vbExclamation, Caption
        SSTab1.Tab = 1
        dteDisc(1).SetFocus
        GoTo ErrHandle
    End If
    If dteDisc(0).Text > dteDisc(1).Text Then
        ShowMsg hWnd, "促销折扣的开始日期不能大于结束日期!", vbExclamation, Caption
        SSTab1.Tab = 1
        dteDisc(0).SetFocus
        GoTo ErrHandle
    End If
    strSql = "UPDATE ItemSaleDisc SET strStartDate='" & dteDisc(0).Text & "'," _
        & "strEndDate='" & dteDisc(1).Text & "',dblDiscountRate=" _
        & TxtToDouble(txtDisc(0).Text) & " WHERE lngItemSaleDiscID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    
    strSql = "DELETE FROM ItemSaleDiscDetail WHERE lngItemSaleDiscID=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    For i = 1 To msgGrid2.Rows - 1
        If msgGrid2.RowHeight(i) > 0 Then
            strSql = "INSERT INTO ItemSaleDiscDetail(lngItemSaleDiscDetailID,lngItemSaleDiscID,lngItemID," _
                & "dblDiscountRate) VALUES(" & GetNewID("ItemSaleDiscDetail") & "," & lngID & "," & msgGrid2.TextMatrix(i, 1) _
                & "," & TxtToDouble(msgGrid2.TextMatrix(i, 6)) & ")"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
    Next
    SaveSalePage = True
ErrHandle:
End Function

Private Function SaveOrderPage() As Boolean
    Dim b As Byte, blnIsSel As Boolean, strName As String, strSql As String
    
    On Error GoTo ErrHandle
    SaveOrderPage = False
    For b = 1 To 5
        blnIsSel = (msgGrid3.TextMatrix(b, 2) = "√")
        strName = msgGrid3.TextMatrix(b, 1)
        If mblnNoFind Then
            strSql = "INSERT INTO Setting(lngModuleID,strSection,strKey,strSetting," _
                & "strTypeName) Values(7,'折扣顺序','" & strName & "','" & b _
                & "','Integer')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            strSql = "INSERT INTO Setting(lngModuleID,strSection,strKey,strSetting," _
                & "strTypeName) Values(7,'折扣启用','" & strName & "','" & blnIsSel _
                & "','Boolean')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            strSql = "UPDATE Setting SET strSetting='" & b & "' WHERE " _
                & "strSection='折扣顺序' AND strKey='" & strName & "' AND lngModuleID=7"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            strSql = "UPDATE Setting SET strSetting='" & blnIsSel & "' WHERE " _
                & "strSection='折扣启用' AND strKey='" & strName & "' AND lngModuleID=7"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
    Next b
    SaveOrderPage = True
ErrHandle:
End Function

Private Sub lstDisc_Delete(index As Integer)
    If mlngLstID(index) = 0 Then
        ShowMsg hWnd, "请先选择参照!", vbExclamation, Caption
        Exit Sub
    End If
    If index = 0 Then
        If frmPayDiscCard.DelCard(mlngLstID(0)) Then
            mlngLstID(0) = 0
            InitPayGrid mlngLstID(0)
        End If
    Else
        If frmSaleDiscCard.DelCard(mlngLstID(1)) Then
            mlngLstID(1) = 0
            InitSalePage lstDisc(1).ReferRow
        End If
    End If
    setlistbox lstDisc(index), 31 + index, mlngLstID(index)
    mstrDiscName(index) = lstDisc(index).Text
End Sub

Private Sub Paste()
    On Error Resume Next
    With msgGrid0
    If .Row = 0 Then Exit Sub
    If Trim$(.TextMatrix(.Row, .col)) <> "" Then
        dteInput.Text = Trim$(.TextMatrix(.Row, .col))
    ElseIf .col = 3 Then
        dteInput.Text = DateAdd("d", 1, CDate(Trim$(.TextMatrix(.Row, 2))))
    End If
    dteInput.Move .Left + .CellLeft - 10, .top + .CellTop - 10, .ColWidth(.col)
    dteInput.SetFocus
    End With
End Sub

Private Sub lstDisc_Edit(index As Integer)
    If index = 0 Then
        frmPayDiscCard.EditCard mlngLstID(0), 1, lstDisc(index).Text
    Else
        frmSaleDiscCard.EditCard mlngLstID(1), 1, lstDisc(index).Text
    End If
    setlistbox lstDisc(index), 31 + index, mlngLstID(index)
    mstrDiscName(index) = lstDisc(index).Text
End Sub

Private Sub lstDisc_ItemNotExist(index As Integer)
    Dim lngID As Long
    
    mblnIsExist = True
    Select Case index
    Case 0
        If frmMsgAdd.MsgAddShow(Caption, "贴息折扣中没有" & lstDisc(0).Text) = vbOK Then
            lngID = frmPayDiscCard.AddCard(lstDisc(0).Text, 1)
        Else
            lstDisc(index).Text = ""
        End If
    Case 1
        If frmMsgAdd.MsgAddShow(Caption, "促销折扣中没有" & lstDisc(1).Text) = vbOK Then
            lngID = frmSaleDiscCard.AddCard(lstDisc(1).Text, 1)
        Else
            lstDisc(index).Text = ""
        End If
    End Select
    If lngID <> 0 Then
        SaveData
        mlngLstID(index) = lngID
    End If
    setlistbox lstDisc(index), 31 + index, mlngLstID(index)
    If index = 0 Then
        InitPayGrid mlngLstID(0)
    Else
        InitSalePage lstDisc(1).ReferRow
    End If
    mblnIsExist = False
    mstrDiscName(index) = lstDisc(index).Text
End Sub

Private Sub mclsMainControl_EditUndo()

End Sub

Private Sub lstDisc_LostFocus(index As Integer)
'    mlngLstID(Index) = lstDisc(Index).ID
End Sub

Private Sub mclsGrid2_AfterColResize(lngCol As Long)
    txtSale.Visible = False
End Sub

Private Sub msgGrid0_Click()
    If msgGrid0.col = 2 Or msgGrid0.col = 3 Then Paste
End Sub

Private Sub msgGrid0_EnterCell()
    If msgGrid0.col = 2 Or msgGrid0.col = 3 Then
        Paste
    End If
End Sub

Private Sub msgGrid2_DblClick()
    With msgGrid2
        If .Row = 0 Or .col <> 6 Then Exit Sub
        EditGrid 0
    End With
End Sub

Private Sub msgGrid2_KeyUp(KeyCode As Integer, Shift As Integer)
    With msgGrid2
        If .Row = 0 Or .col <> 6 Then Exit Sub
        If (Chr(KeyCode) >= "0" And Chr(KeyCode) <= "9") Or Chr(KeyCode) = "." Then
            EditGrid KeyCode
        Else
            EditGrid 0
        End If
    End With
End Sub

Private Sub msgGrid2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgGrid2
        If y < .Rows * .RowHeight(0) And y > .RowHeight(0) Then
            If .MouseCol = 2 Then
                .MousePointer = flexCustom
            Else
                .MousePointer = flexDefault
            End If
        End If
    End With
End Sub

Private Sub msgGrid2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Button = vbLeftButton Then
        If msgGrid2.MousePointer = flexCustom Then
            If msgGrid2.TextMatrix(msgGrid2.Row, 2) = "√" Then
                msgGrid2.TextMatrix(msgGrid2.Row, 2) = ""
            Else
                msgGrid2.TextMatrix(msgGrid2.Row, 2) = "√"
            End If
            mblnSaleIsChanged = True
        End If
    End If
End Sub

Private Sub msgGrid2_Scroll()
    txtSale.Visible = False
End Sub

Private Sub msgGrid3_EnterCell()
    mlngOrderRow = msgGrid3.Row
    SetButton
End Sub

Private Sub msgGrid3_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeySpace Then
        If msgGrid3.TextMatrix(msgGrid3.Row, 2) = "√" Then
            msgGrid3.TextMatrix(msgGrid3.Row, 2) = ""
        Else
            msgGrid3.TextMatrix(msgGrid3.Row, 2) = "√"
        End If
        mblnOrderIsChanged = True
    End If
End Sub

Private Sub msgGrid3_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgGrid3
        If y < .Rows * .RowHeight(0) And y > .RowHeight(0) Then
            If .MouseCol = 2 Then
                .MousePointer = flexCustom
            Else
                .MousePointer = flexDefault
            End If
        End If
    End With
End Sub

Private Sub msgGrid3_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
        If msgGrid3.MousePointer = flexCustom Then
            If msgGrid3.TextMatrix(msgGrid3.Row, 2) = "√" Then
                msgGrid3.TextMatrix(msgGrid3.Row, 2) = ""
            Else
                msgGrid3.TextMatrix(msgGrid3.Row, 2) = "√"
            End If
            mblnOrderIsChanged