frmstockinout.frm

金算盘软件代码

    Utility.RemoveListRecordSet lrtPosition
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub


'************************************************************************************
'*
'*
'*
'************************************************************************************
Private Sub InitComBox()
    Dim strSql As String
    Dim recDetail As rdoResultset
    
    cboStock.Clear
    cboStock.AddItem "全部"
    strSql = "SELECT lngPositionID,strPositionCode,strPositionName " _
        & "FROM Position WHERE blnIsInActive=0 ORDER BY strPositionCode"
    Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    Do While Not recDetail.EOF
        cboStock.AddItem recDetail!strPositionCode & " " & recDetail!strPositionName
        recDetail.MoveNext
    Loop
    recDetail.Close
    Set recDetail = Nothing
    cboStock.ListIndex = 0
    
    cldBegin.Value = Format(gclsBase.BaseDate, "yyyy-mm-dd")
    cldEnd.Value = Format(gclsBase.BaseDate, "yyyy-mm-dd")
End Sub

Private Function GetList(Optional strFilter As String) As rdoResultset
    Dim strSql As String
    Dim strCon As String
    Dim recDetail As rdoResultset
    
    strCon = " ItemActivityDetail.lngPositionID>0 AND strDate>='" & cldBegin.Text _
        & "' AND strDate<='" & cldEnd.Text & "' AND dblQuantity<>0 AND dblQuantity<>dblPositionQuantity "
    If mstrOp = "入库" Then
        strCon = strCon & " AND lngActivityTypeID IN(1,3,5,8,9,10)"
    Else
        strCon = strCon & " AND lngActivityTypeID IN(11,13,15,16,19,21,22)"
    End If
    If strFilter <> "" Then strCon = strCon & " AND " & strFilter
    If cboStock.ListIndex > 0 Then
        strSql = "SELECT lngPositionID FROM Position WHERE strPositionCode & ' ' & strPositionName='" & cboStock.Text & "'"
        Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recDetail.EOF Then
            strCon = strCon & " AND ItemActivityDetail.lngPositionID=" & recDetail!lngPositionID
        End If
        recDetail.Close
    End If
    strSql = "SELECT lngActivityDetailID,ItemUnit.dblFactor,'' As 选择," _
        & mclsGrid.ListSet.SelectOfSql & " " _
        & mclsGrid.ListSet.FromOfSql & " WHERE " _
        & mclsGrid.ListSet.WhereOfSql & " AND " _
        & strCon
    Set GetList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Function

Private Sub mclsGrid_BeforeSave(blnCancel As Boolean)
    If txtEdit.Value = 0 Then txtEdit.Text = ""
    mblnModify = True
End Sub

Private Sub msgBody_Click()
    Dim blnChk As Boolean
    Dim lngRow As Long
    Dim intCol As Integer
    
    lngRow = msgBody.MouseRow
    intCol = msgBody.MouseCol
    
    If lngRow >= 1 And lngRow < msgBody.Rows And intCol = mintFlagCol Then
        blnChk = False
        If Not IsNull(msgBody.TextMatrix(lngRow, mintFlagCol)) Then
            If msgBody.TextMatrix(lngRow, mintFlagCol) = "√" Then
                blnChk = True
            End If
        End If
        If Not blnChk Then
            CheckOne lngRow
        Else
            CancelOne lngRow
        End If
        mblnModify = True
    End If
End Sub

Private Sub msgBody_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngRow As Long
    Dim intCol As Integer
    
    lngRow = msgBody.MouseRow
    intCol = msgBody.MouseCol
    If lngRow >= 1 And lngRow < msgBody.Rows And intCol = mintFlagCol Then
        msgBody.MousePointer = vbCustom
    Else
        msgBody.MousePointer = vbDefault
    End If
End Sub

Private Function FindEditCol() As Boolean
    Dim intCol As Integer
    
    For intCol = 1 To mclsGrid.ListSet.Columns
        If UCase(mclsGrid.ListSet.ColumnFieldName(intCol)) = UCase("dblQuantity") Then
            mintTotalCol = intCol + mclsGrid.ColOfs - 1
        ElseIf UCase(mclsGrid.ListSet.ColumnFieldName(intCol)) = UCase("dblPositionQuantity") Then
            mintLastChkCol = intCol + mclsGrid.ColOfs - 1
        ElseIf UCase(mclsGrid.ListSet.ColumnFieldName(intCol)) = UCase("0") Then
            mintEditCol = intCol + mclsGrid.ColOfs - 1
        End If
    Next intCol
    
    FindEditCol = ((mintTotalCol > 0) And (mintLastChkCol > 0) And (mintEditCol > 0))
End Function

Private Sub CheckOne(lngRow As Long)
    Dim blnChk As Boolean
    Dim dblTotalQuantity As Double
    Dim dblLastQuantity As Double
    Dim strQuantity As String
    Dim dblFactor As Double
    
    blnChk = False
    If Not IsNull(msgBody.TextMatrix(lngRow, mintFlagCol)) Then
        If msgBody.TextMatrix(lngRow, mintFlagCol) = "√" Then
            blnChk = True
        End If
    End If
    
    If Not blnChk Then
        dblFactor = GetValue(lngRow, mintFactorCol)
        dblTotalQuantity = NormalToMinQty(GetValue(lngRow, mintTotalCol), dblFactor)
        dblLastQuantity = NormalToMinQty(GetValue(lngRow, mintLastChkCol), dblFactor)
        strQuantity = MinToNormalQty(dblTotalQuantity - dblLastQuantity, dblFactor)
        msgBody.TextMatrix(lngRow, mintFlagCol) = "√"
        msgBody.TextMatrix(lngRow, mintEditCol) = strQuantity
    End If
End Sub

Private Sub CancelOne(lngRow As Long)
    If Not IsNull(msgBody.TextMatrix(lngRow, mintFlagCol)) Then
        If msgBody.TextMatrix(lngRow, mintFlagCol) = "√" Then
            msgBody.TextMatrix(lngRow, mintFlagCol) = ""
            msgBody.TextMatrix(lngRow, mintEditCol) = 0
        End If
    End If
End Sub

Private Function SaveData() As Boolean
    Dim lngRow As Long
    Dim lngActivityDetailID As Long
    Dim dblQuantity As Double
    Dim dblLastQuantity As Double
    Dim dblFactor As Double
    Dim blnSucceed As Boolean
    Dim strSql As String
    
    blnSucceed = True
    For lngRow = 1 To msgBody.Rows - 1
        dblFactor = GetValue(lngRow, mintFactorCol)
        dblQuantity = NormalToMinQty(GetValue(lngRow, mintEditCol), dblFactor)
            
        If dblQuantity <> 0 Then
            dblLastQuantity = NormalToMinQty(GetValue(lngRow, mintLastChkCol), dblFactor)
            lngActivityDetailID = GetValue(lngRow, mintIDCol)
            
            strSql = "UPDATE ItemActivityDetail SET dblPositionQuantity=" & dblLastQuantity + dblQuantity _
                & " WHERE lngActivityDetailID=" & lngActivityDetailID
            blnSucceed = gclsBase.ExecSQL(strSql)
            If Not blnSucceed Then Exit For
        End If
    Next lngRow
    
    If Not blnSucceed Then
        ShowMsg hWnd, "存盘失败！", vbCritical + vbOKOnly, Caption
    Else
        mblnModify = False
    End If
    SaveData = blnSucceed
End Function

'************************************************************************************
'*
'*  命令按钮
'*
'************************************************************************************

Private Sub CancelAll()
    Dim lngRow As Long
    
    For lngRow = 1 To msgBody.Rows - 1
        CancelOne lngRow
    Next lngRow
End Sub

Private Sub CheckAll()
    Dim lngRow As Long
    
    For lngRow = 1 To msgBody.Rows - 1
        CheckOne lngRow
    Next lngRow
End Sub

Private Sub FilterChk()
    Dim strFilter As String
    Dim recDetail As rdoResultset
    Dim blnOK As Boolean
    Dim strIDs As String
    Dim lngRow As Long
    Dim lngActivityDetailID As Long
    
    strFilter = Filter.ShowFilter(mclsGrid.ListSet.ListID, 1, , , , , blnOK)
    If blnOK Then
        If strFilter = "" Then
            CheckAll
        Else
            Set recDetail = GetList(strFilter)
            If Not recDetail Is Nothing Then
                strIDs = ","
                Do While Not recDetail.EOF
                    strIDs = strIDs & recDetail!lngActivityDetailID & ","
                    recDetail.MoveNext
                Loop
                recDetail.Close
            End If
            If strIDs <> "" Then
                For lngRow = 1 To msgBody.Rows - 1
                    lngActivityDetailID = GetValue(lngRow, mintIDCol)
                    
                    If InStr(strIDs, "," & lngActivityDetailID & ",") > 0 Then
                        CheckOne lngRow
                    End If
                Next lngRow
            End If
        End If
    End If
End Sub

Private Sub SetColumns()
    SaveData
    mclsGrid.ListSet.SaveList
    mclsGrid.ListSet.ShowListSet mclsGrid.ListSet.ViewId, False
    RefreshGrid
End Sub

'************************************************************************************
'*
'*  Grid 借口
'*
'************************************************************************************
Private Sub RefreshGrid()
    msgBody.Rows = 1
    msgBody.FixedCols = 0
    Set datSource.Resultset = GetList()
    mclsGrid.ColOfs = 3
    FindEditCol
    msgBody.ColWidth(0) = 0
    msgBody.ColWidth(1) = 0
    msgBody.ColWidth(2) = 450
    mclsGrid.SetupStyle
    mclsGrid.ListSetToGrid
    Set mclsGrid.EditText = txtEdit
    If mstrOp = "入库" Then
        mclsGrid.SetEditText "本次入库数量"
    Else
        mclsGrid.SetEditText "本次出库数量"
    End If
End Sub

Private Sub mclsGrid_AfterRefresh(lngRow As Long)
    With msgBody
        If mintTotalCol > 0 Then
            .TextMatrix(lngRow, mintTotalCol) = MinToNormalQty(GetValue(lngRow, mintTotalCol), GetValue(lngRow, mintFactorCol))
        End If
        If mintLastChkCol > 0 Then
            .TextMatrix(lngRow, mintLastChkCol) = MinToNormalQty(GetValue(lngRow, mintLastChkCol), GetValue(lngRow, mintFactorCol))
        End If
        If mintEditCol > 0 Then
            .TextMatrix(lngRow, mintEditCol) = MinToNormalQty(GetValue(lngRow, mintEditCol), GetValue(lngRow, mintFactorCol))
        End If
    End With
End Sub

Private Sub mclsGrid_DataValid(blnCancel As Boolean)
    Dim strMsg As String
    blnCancel = (Not DataValid(strMsg))
    If strMsg <> "" Then
        ShowMsg hWnd, strMsg, vbExclamation + vbOKOnly, Caption
    End If
End Sub

Private Function DataValid(Optional strMsg As String) As Boolean
    Dim dblQuantity As Double
    Dim dblTotalQuantity As Double
    Dim dblLastQuantity As Double
    Dim dblFactor As Double
    Dim lngRow As Long
    Dim Val As String
    Dim strFlag As String
    Dim blnCancel As Boolean
    
    If mstrOp = "入库" Then
        strFlag = "入"
    Else
        strFlag = "出"
    End If
    lngRow = msgBody.Row
    Val = txtEdit.Text
    dblFactor = GetValue(lngRow, mintFactorCol)
    dblTotalQuantity = NormalToMinQty(GetValue(lngRow, mintTotalCol), dblFactor)
    dblLastQuantity = NormalToMinQty(GetValue(lngRow, mintLastChkCol), dblFactor)
    dblQuantity = NormalToMinQty(C2Dbl(Val), dblFactor)
    
    If dblLastQuantity <> 0 Then
        If dblLastQuantity * dblQuantity < 0 Then
            If Abs(dblLastQuantity) < Abs(dblQuantity) Then
                blnCancel = True
                strMsg = "本次" & strFlag & "库数量不能大于已" & strFlag & "库数量！"
            End If
        End If
    Else
        If dblTotalQuantity * dblQuantity < 0 Then
            blnCancel = True
            strMsg = "本次" & strFlag & "库数量必须与应" & strFlag & "库数量符号相同！"
        Else
            If dblTotalQuantity > 0 Then
                If dblTotalQuantity < dblQuantity Then
                    blnCancel = True
                    strMsg = "本次" & strFlag & "库数量不能大于未" & strFlag & "库数量！"
                End If
            Else
                If dblTotalQuantity > dblQuantity Then
                    blnCancel = True
                    strMsg = "本次" & strFlag & "库数量不能大于未" & strFlag & "库数量！"
                End If
            End If
        End If
    End If
    If blnCancel = False And dblQuantity <> 0 Then
        msgBody.TextMatrix(lngRow, mintFlagCol) = "√"
    End If
    
    DataValid = (Not blnCancel)
End Function

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgBody)
End Function