frmitemdisclistcard.frm

金算盘软件代码

    mblnSaleIsChanged = False
    mblnOrderIsChanged = False
    mblnIsInit = True
'    InitPayPage
'    setlistbox lstDisc(1), 32, mlngLstID(1)
'    If lstDisc(1).Referrows > 3 Then
'        lstDisc(1).ReferRow = 4
'    End If
'    InitSalePage lstDisc(1).ReferRow
'    InitOrderPage
'    SetTabIndex
'    mblnIsInit = False
'    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub InitPayPage()
    setlistbox lstDisc(0), 31, mlngLstID(0)
    If lstDisc(0).Referrows > 3 Then
        lstDisc(0).ReferRow = 4
    End If
    InitPayGrid mlngLstID(0)
End Sub

Private Sub InitSalePage(ByVal iRow As Long)
    Dim strSql As String
    
    If Trim(lstDisc(1).TextMatrix(iRow, 3)) <> "" Then
        dteDisc(0).Text = lstDisc(1).TextMatrix(iRow, 3)
    End If
    If Trim(lstDisc(1).TextMatrix(iRow, 4)) <> "" Then
        dteDisc(1).Text = lstDisc(1).TextMatrix(iRow, 4)
    End If
    txtDisc(0).Text = lstDisc(1).TextMatrix(iRow, 5)
    strSql = "SELECT lngItemSaleDiscDetailID,Item.lngItemID,' ' AS ""选择"",Item.strItemCode AS " _
        & """商品编码"",Item.strItemName AS ""商品名称"",Item.strItemStyle AS ""规格型号""," _
        & "dblDiscountRate AS ""[扣率％]"" FROM ItemSaleDiscDetail,Item " _
        & "WHERE ItemSaleDiscDetail.lngItemID=Item.lngItemID AND " _
        & "lngItemSaleDiscID=" & mlngLstID(1) & " ORDER BY Item.lngItemID"
    InitSaleGrid strSql
End Sub

Private Sub InitSaleGrid(ByVal strSql As String)
    Dim recSale As rdoResultset, l As Long

    Set recSale = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recSale.EOF Then
        msgGrid2.Cols = 0
        Set DATA3.Resultset = recSale
        DATA3.Resultset.MoveLast
        DATA3.Resultset.Close
    Else
        msgGrid2.Rows = 1
        recSale.Close
    End If
    For l = 1 To msgGrid2.Rows - 1
        msgGrid2.TextMatrix(l, 6) = FormatShow(msgGrid2.TextMatrix(l, 6), gclsBase.NaturalCurDec)
    Next l
    msgGrid2.ColWidth(0) = 0
    msgGrid2.ColWidth(1) = 0
    msgGrid2.ColWidth(2) = 450
    msgGrid2.ColWidth(3) = msgGrid2.width / 5 + 200
    msgGrid2.ColWidth(4) = msgGrid2.width / 5 + 200
    msgGrid2.ColWidth(5) = msgGrid2.width / 5 + 200
    msgGrid2.ColWidth(6) = msgGrid2.width / 5 + 120
    msgGrid2.ColAlignment(6) = flexAlignRightCenter
    mclsGrid2.SetupStyle
'    mclsGrid2.SetWriteCol 6
End Sub

Private Sub InitPayGrid(ByVal lngID As Long)
    Dim recPay As rdoResultset, strSql As String, l As Long
    
    strSql = "SELECT lngItemPayDiscDateID,1,strStartDate AS ""启用日期""," _
        & "strEndDate AS ""结束日期"",dblDiscountRate AS ""[贴息扣率%]"" FROM " _
        & "ItemPayDiscDate WHERE lngItemPayDiscID=" & lngID _
        & " ORDER BY strStartDate"
    Set recPay = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recPay.EOF Then
        msgGrid0.Cols = 0
        Set Data1.Resultset = recPay
        Data1.Resultset.MoveLast
        Data1.Resultset.Close
        mlngPayRow = 1
    Else
        msgGrid0.Rows = 1
        mlngPayRow = 0
        recPay.Close
    End If
    For l = 1 To msgGrid0.Rows - 1
        msgGrid0.TextMatrix(l, 4) = FormatShow(msgGrid0.TextMatrix(l, 4), gclsBase.NaturalCurDec)
    Next l
    msgGrid0.ColWidth(0) = 0
    msgGrid0.ColWidth(1) = 0
    msgGrid0.ColWidth(2) = msgGrid0.width / 3
    msgGrid0.ColWidth(3) = msgGrid0.width / 3
    msgGrid0.ColWidth(4) = msgGrid0.width / 3 - 100
    msgGrid0.ColAlignment(4) = flexAlignRightCenter
    mclsGrid0.SetupStyle
    mclsGrid0.SetWriteCol 4
    
    strSql = "SELECT ItemPayDiscDetail.lngItemID,Item.strItemCode AS ""商品编码""," _
        & "Item.strItemName AS ""商品名称"", Item.strItemStyle AS ""规格型号""," _
        & "ItemUnit.strUnitName AS ""常用计量单位"" FROM ItemPayDiscDetail ,Item,ItemUnit " _
        & "WHERE ItemPayDiscDetail.lngItemID=Item.lngItemID And " _
        & "Item.lngStockUnitID=ItemUnit.lngUnitID And ItemPayDiscDetail.lngItemPayDiscID=" & lngID
    InitPayGrid1 strSql
End Sub

Private Sub InitPayGrid1(ByVal strSql As String)
    Dim recPay As rdoResultset
    
    Set recPay = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recPay.EOF Then
        msgGrid1.Cols = 0
        Set DATA2.Resultset = recPay
        DATA2.Resultset.MoveLast
        DATA2.Resultset.Close
    Else
        msgGrid1.Rows = 1
        recPay.Close
    End If
    msgGrid1.ColWidth(0) = 0
    msgGrid1.ColWidth(1) = msgGrid1.width / 4
    msgGrid1.ColWidth(2) = msgGrid1.width / 4
    msgGrid1.ColWidth(3) = msgGrid1.width / 4
    msgGrid1.ColWidth(4) = msgGrid1.width / 4 - 60
    mclsGrid1.SetupStyle
End Sub

Private Sub InitOrderPage()
    Dim b As Byte
    Dim recOrder As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM Setting WHERE lngModuleID=7 ORDER BY strSetting"
    Set recOrder = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recOrder.EOF Then
        msgGrid3.TextMatrix(1, 0) = 1
        msgGrid3.TextMatrix(1, 1) = "商品折扣"
        msgGrid3.TextMatrix(2, 0) = 2
        msgGrid3.TextMatrix(2, 1) = "批量折扣"
        msgGrid3.TextMatrix(3, 0) = 3
        msgGrid3.TextMatrix(3, 1) = "促销折扣"
        msgGrid3.TextMatrix(4, 0) = 4
        msgGrid3.TextMatrix(4, 1) = "客户折扣"
        msgGrid3.TextMatrix(5, 0) = 5
        msgGrid3.TextMatrix(5, 1) = "贴息折扣"
        mblnNoFind = True
    Else
        b = 1
        Do Until b > 5
            msgGrid3.TextMatrix(b, 0) = b
            msgGrid3.TextMatrix(b, 1) = recOrder("strKey")
            recOrder.MoveNext
            b = b + 1
        Loop
        Do Until recOrder.EOF
            For b = 1 To 5
                If msgGrid3.TextMatrix(b, 1) = recOrder("strKey") Then
                    If (recOrder("strSetting") = "True") Then
                        msgGrid3.TextMatrix(b, 2) = "√"
                    End If
                    Exit For
                End If
            Next b
            recOrder.MoveNext
        Loop
        mblnNoFind = False
    End If
    mlngOrderRow = 1
'    recOrder.Close
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If Not mblnCancel Then
        If Not SaveData Then Cancel = 1
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Set mclsGrid0 = Nothing
    Set mclsGrid1 = Nothing
    Set mclsGrid2 = Nothing
    Utility.UnLoadFormResPicture Me
    Utility.RemoveFormResPicture 2001
'    gclsSys.MainControls.Remove Me
'    Set mclsMainControl = Nothing
End Sub

Private Sub lstDisc_AddNew(index As Integer)
    Dim lngID As Long, blnR As Boolean
    
    blnR = (mlngLstID(index) > 0)
    If index = 0 Then
        lngID = frmPayDiscCard.AddCard(, 1)
        If lngID <> 0 Then
            If mblnPayIsChanged And mlngLstID(0) > 0 Then
                If ShowMsg(hWnd, "您要保存贴息折扣吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
                    If Not SavePayPage(mlngLstID(0)) Then Exit Sub
                End If
            End If
            mlngLstID(index) = lngID
        End If
        setlistbox lstDisc(index), 31 + index, mlngLstID(index)
        If blnR Then InitPayGrid mlngLstID(0)
    Else
        lngID = frmSaleDiscCard.AddCard(, 1)
        If lngID <> 0 Then
            If mblnSaleIsChanged And mlngLstID(1) > 0 Then
                If ShowMsg(hWnd, "您要保存促销折扣吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
                    If Not SaveSalePage(mlngLstID(1)) Then Exit Sub
                End If
            End If
            mlngLstID(index) = lngID
        End If
        setlistbox lstDisc(index), 31 + index, mlngLstID(index)
        If blnR Then InitSalePage lstDisc(1).ReferRow
    End If
    mstrDiscName(index) = lstDisc(index).Text
End Sub

Private Sub lstDisc_Choose(index As Integer)
    If mlngLstID(index) <> lstDisc(index).TextMatrix(lstDisc(index).ReferRow, 1) Then
        SaveData
        mlngLstID(index) = lstDisc(index).TextMatrix(lstDisc(index).ReferRow, 1)
        If index = 0 Then
            If mlngLstID(0) <> 0 Then InitPayGrid mlngLstID(0)
        Else
            If mlngLstID(1) > 0 Then InitSalePage lstDisc(1).ReferRow
        End If
    End If
    mstrDiscName(index) = lstDisc(index).Text
End Sub

Private Function SaveData() As Boolean
    Dim l As Long
    
    On Error GoTo ErrHandle
    SaveData = False
    If mblnIsExist Then Exit Function
    gclsBase.BaseWorkSpace.BeginTrans
    If mblnPayIsChanged Then
        If ShowMsg(hWnd, "您要保存贴息折扣吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
            For l = 1 To msgGrid0.Rows - 1
                If msgGrid0.RowHeight(l) > 0 And msgGrid0.TextMatrix(l, 2) <> "" And msgGrid0.TextMatrix(l, 3) <> "" Then Exit For
            Next l
            If l < msgGrid0.Rows Then
'                If ShowMsg(hWnd, "您要保存贴息折扣吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
                    If Not SavePayPage(mlngLstID(0)) Then GoTo ErrHandle
'                End If
            Else
                ShowMsg hWnd, "贴息折扣至少要有一条完整的折扣信息!", vbExclamation, Caption
                GoTo ErrHandle
            End If
        End If
    End If
    If mblnSaleIsChanged Then
        If ShowMsg(hWnd, "您要保存促销折扣吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
            If Not SaveSalePage(mlngLstID(1)) Then GoTo ErrHandle
        End If
    End If
    If mblnOrderIsChanged Then
        If ShowMsg(hWnd, "您要保存折扣顺序吗?", vbQuestion + vbYesNo, Caption) = vbYes Then
            If Not SaveOrderPage Then GoTo ErrHandle
        End If
    End If
    SaveData = True
    mblnPayIsChanged = False
    mblnSaleIsChanged = False
    mblnOrderIsChanged = False
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function SavePayPage(ByVal lngID As Long) As Boolean
     Dim i As Long, recDiscDate As rdoResultset, strSql As String, strDateID As String
    
    On Error GoTo ErrHandle
    
    SavePayPage = False
    If mstrDiscName(0) = "" Then
        ShowMsg hWnd, "贴息折扣的名称不能为空!", vbExclamation, Caption
        SSTab1.Tab = 0
        lstDisc(0).SetFocus
        GoTo ErrHandle
    ElseIf lngID = 0 Then
        strSql = "SELECT lngItemPayDiscID FROM ItemPayDisc WHERE strItemPayDiscName" _
            & "='" & lstDisc(0).Text & "'"
        Set recDiscDate = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recDiscDate.EOF Then
            lngID = recDiscDate("lngItemPayDiscID")
        Else
            lngID = GetNewID("ItemPayDisc")
            strSql = "INSERT INTO ItemPayDisc(lngItemPayDiscID,strItemPayDiscName) VALUES(" _
                & lngID & ",'" & lstDisc(0).Text & "')"
            gclsBase.ExecSQL strSql
        End If
        recDiscDate.Close
    End If
    strDateID = ""
    With msgGrid0
        For i = 1 To .Rows - 1
            If Not CheckPayDate(i) Then GoTo ErrHandle
            If .TextMatrix(i, 1) = "-5" Then
                If TxtToDouble(.TextMatrix(i, 0)) <> "0" Then
                    strSql = "DELETE FROM ItemPayDiscDate WHERE " _
                        & "lngItemPayDiscDateID=" & .TextMatrix(i, 0)
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                Else
                    strSql = ""
                End If
            ElseIf .TextMatrix(i, 2) <> "" And .TextMatrix(i, 3) <> "" Then
                If .TextMatrix(i, 2) > .TextMatrix(i, 3) Then
                    ShowMsg hWnd, "贴息折扣开始日期不能大于结束日期!", vbExclamation, Caption
                    SSTab1.Tab = 0
                    GoTo ErrHandle
                End If
                If TxtToDouble(.TextMatrix(i, 0)) = "0" Then
                    strSql = "INSERT INTO ItemPayDiscDate(lngItemPayDiscDateID,lngItemPayDiscID," _
                        & "strStartDate,strEndDate,dblDiscountRate) VALUES(" & GetNewID("ItemPayDiscDate") _
                        & "," & lngID & ",'" & .TextMatrix(i, 2) & "','" _
                        & .TextMatrix(i, 3) & "'," & TxtToDouble(.TextMatrix(i, 4)) & ")"
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                    strSql = "SELECT * FROM ItemPayDiscDate WHERE strStartDate='" _
                        & .TextMatrix(i, 2) & "' AND strEndDate='" & .TextMatrix(i, 3) _
                        & "' AND dblDiscountRate=" & TxtToDouble(.TextMatrix(i, 4))
                    Set recDiscDate = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If Not recDiscDate.EOF Then
                        strDateID = strDateID & "," & recDiscDate("lngItemPayDiscDateID")
                    End If
                    recDiscDate.Close
                Else
                    strSql = "UPDATE ItemPayDiscDate SET strStartDate='" _
                        & .TextMatrix(i, 2) & "',strEndDate='" & .TextMatrix(i, 3) _
                        & "',dblDiscountRate=" & TxtToDouble(.TextMatrix(i, 4)) _
                        & " WHERE lngItemPayDiscDateID=" & .TextMatrix(i, 0)
                    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
                    strDateID = strDateID & "," & .TextMatrix(i, 0)
                End If
            End If
        Next i
    End With
    
    With msgGrid1
        On Error Resume Next
        For i = 1 To .Rows - 1
            If DataIsValid(lngID, .TextMatrix(i, 0), strDateID) Then
                strSql = "INSERT INTO ItemPayDiscDetail(lngItemPayDiscID,lngItemID) " _
                    & "VALUES(" & lngID & "," & .TextMatrix(i, 0) & ")"