frmcalcsinglechoice.frm

金算盘软件代码

    Dim strSql As String, strInOutID As String
    Dim lngOrderID As Long
    Dim errNo As Long
    Dim intYear As Integer
    Dim bytPeriod As Integer
    
    intYear = GetintYear(frmCalcCost.cboCost(0).Text)
    bytPeriod = GetbytPeriod(frmCalcCost.cboCost(0).Text)
    
    On Error GoTo ErrHandle
    
    With msgBody
        '清理原来出库数据
        For lngRow = .FixedRows To .Rows - 1
            If CLng(.TextMatrix(lngRow, mintColOutID)) > 0 Then
                If .TextMatrix(lngRow, mintColState) = "" Then
                    '删除原来数据
                    strSql = "DELETE FROM ItemCostDetail WHERE lngItemID=" _
                            & mlngItemID & " AND lngOutActivityDetailID=" & mlngOutID
                    gclsBase.ExecSQL strSql
                    strSql = "UPDATE CostDetail SET dblSaleQuantity=dblSaleQuantity-" & C2Dbl(.TextMatrix(lngRow, mintColBakOutQty)) _
                        & ",dblSaleAmount=dblSaleAmount-" & C2Dbl(.TextMatrix(lngRow, mintColBakOutAmt)) _
                        & " WHERE lngActivityDetailID=" & .TextMatrix(lngRow, mintColInID)
                    gclsBase.ExecSQL strSql
                End If
            End If
        Next lngRow
        
        '本次选择数据
        For lngRow = .FixedRows To .Rows - 1
            If .TextMatrix(lngRow, mintColState) = "√" Then
                If CLng(.TextMatrix(lngRow, mintColOutID)) = 0 Then
                    '新选数据
                    strSql = "INSERT INTO ItemCostDetail VALUES (" & mlngItemID & "," _
                        & .TextMatrix(lngRow, mintColInID) & "," & mlngOutID & "," & .TextMatrix(lngRow, mintColOutQuantity) _
                        & "," & .TextMatrix(lngRow, mintColOutAmount) & ")"
                    gclsBase.ExecSQL strSql
                Else
                    '修改原来数据
                    strSql = "UPDATE ItemCostDetail SET dblQuantity=" & .TextMatrix(lngRow, mintColOutQuantity) & "," _
                        & "dblAmount=" & .TextMatrix(lngRow, mintColOutAmount) & " WHERE lngItemID=" & mlngItemID _
                        & " AND lngOutActivityDetailId=" & mlngOutID & " AND lngInActivityDetailID=" _
                        & .TextMatrix(lngRow, mintColInID)
                    gclsBase.ExecSQL strSql
                    strSql = "UPDATE CostDetail SET dblSaleQuantity=dblSaleQuantity-" & C2Dbl(.TextMatrix(lngRow, mintColBakOutQty)) _
                        & ",dblSaleAmount=dblSaleAmount-" & C2Dbl(.TextMatrix(lngRow, mintColBakOutAmt)) _
                        & " WHERE lngActivityDetailID=" & .TextMatrix(lngRow, mintColInID)
                    gclsBase.ExecSQL strSql
                End If
                strSql = "UPDATE CostDetail SET dblSaleQuantity=dblSaleQuantity+" & .TextMatrix(lngRow, mintColOutQuantity) _
                    & ",dblSaleAmount=dblSaleAmount+" & .TextMatrix(lngRow, mintColOutAmount) _
                    & " WHERE lngActivityDetailID=" & .TextMatrix(lngRow, mintColInID)
                gclsBase.ExecSQL strSql
                If gclsBase.BaseDB.RowsAffected = 0 Then
                    lngOrderID = GetNewID("CostDetail")
                    strSql = "INSERT INTO CostDetail(lngOrderID,intYear,bytPeriod,lngItemID,lngActivityDetailID,blnInit," _
                        & "dblUnSaleQuantity,dblUnSaleAmount,dblSaleQuantity,dblSaleAmount) " _
                        & "VALUES(" & lngOrderID & "," & intYear & "," & bytPeriod & "," & mlngItemID & "," & .TextMatrix(lngRow, mintColInID) & ",0," _
                        & .TextMatrix(lngRow, mintColInQuantity) & "," & .TextMatrix(lngRow, mintColInAmount) & "," _
                        & .TextMatrix(lngRow, mintColOutQuantity) & "," & .TextMatrix(lngRow, mintColOutAmount) & ")"
                    gclsBase.ExecSQL strSql
                End If
                
            End If
        Next lngRow
    End With
    Exit Sub
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        Form 事件、方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form_Load()
    Me.MousePointer = vbHourglass
    
    Me.HelpContextID = HelpID
    frmCalcSingle.AddChildWindow "指定批次"
    With picGrid
        .Visible = True
        .Left = mintLeft
        .top = mintTop
    End With
    With msgHead
        .top = 0
        .Left = 0
    End With
    With msgBody
        .top = msgHead.top + msgHead.Height
        .Left = 0
        .SelectionMode = flexSelectionFree
    End With
    
    'Grid对象
    Set mclsGrid = New MutiGrid
    mclsGrid.ListSet.ViewId = mViewID
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hwnd = Me.hwnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    
    '主控对象
'    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Utility.LoadFormResPicture Me
    '加载窗体位置
    Utility.LoadFormSetting Me
    width = 9780
    Height = 5955
    
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next

    '保存窗体位置
    Utility.SaveFormSetting Me
    '释放窗体资源
    Utility.UnLoadFormResPicture Me
    
    frmCalcSingle.RemoveChildWindow "指定批次"
    
    Set mclsGrid = Nothing
    Set mclsSubClassform = Nothing

End Sub


Private Sub Form_Activate()
    SetHelpID HelpContextID
    frmMain.SetEditUnEnabled
End Sub

Private Sub Form_Resize()
    Dim lngCnt As Long
    On Error Resume Next
    If WindowState <> vbMinimized Then
        If width < mlngFormMinWidth * Screen.TwipsPerPixelX Then
           width = mlngFormMinWidth * Screen.TwipsPerPixelY
        End If
        If Height < mlngFormMinHeight * Screen.TwipsPerPixelY Then
            Height = mlngFormMinHeight * Screen.TwipsPerPixelY
        End If
        cmdList(0).Left = ScaleWidth - cmdList(0).width - 2 * mintLeft
        For lngCnt = 1 To 2
            cmdList(lngCnt).Left = cmdList(0).Left
        Next lngCnt
        
        With picGrid
            .Left = ListFormLeft
            .width = ScaleWidth - 5 * mintLeft - cmdList(0).width
            .Height = ScaleHeight - mintBottomHeight - mintTop
        End With
        msgHead.width = picGrid.ScaleWidth
        msgBody.width = picGrid.ScaleWidth
        msgBody.Height = picGrid.ScaleHeight - msgBody.top
        mclsGrid.FormResize
        txtQuantity.width = TextWidth(txtQuantity.Text) + 100
        txtQuantity.Left = picGrid.Left + picGrid.width - txtQuantity.width - 15
    End If
End Sub


Private Sub mclsGrid_BeforeSave(blnCancel As Boolean)
    Dim dblQuantity As Double
    On Error Resume Next
    mdblInQuantity = mdblInQuantity - GetValue(msgBody.Row, mintColOutQuantity)
    Select Case msgBody.col
    Case mintColOutQuantity
        dblQuantity = txtEdit.Value
        If dblQuantity < GetValue(msgBody.Row, mintColInQuantity) Then
            msgBody.TextMatrix(msgBody.Row, mintColOutAmount) = GetValue(msgBody.Row, mintColInPrice) * txtEdit.Value
        Else
            msgBody.TextMatrix(msgBody.Row, mintColOutAmount) = GetValue(msgBody.Row, mintColInAmount)
        End If
    Case mintColOutAmount
        msgBody.TextMatrix(msgBody.Row, mintColOutQuantity) = GetValue(msgBody.Row, mintColInQuantity) * txtEdit.Value / GetValue(msgBody.Row, mintColInAmount)
        dblQuantity = GetValue(msgBody.Row, mintColOutQuantity)
    End Select
    mdblInQuantity = mdblInQuantity + dblQuantity
    mclsGrid.FormatCell msgBody.Row, mintColOutQuantity, mintColOutAmount
    If dblQuantity > 0 Then
        msgBody.TextMatrix(msgBody.Row, mintColState) = "√"
    Else
        msgBody.TextMatrix(msgBody.Row, mintColState) = ""
    End If
End Sub

Private Sub mclsGrid_DataValid(blnCancel As Boolean)
    Dim dblQuantity As Double
    
    Select Case msgBody.col
    Case mintColOutQuantity
        If txtEdit.Value > GetValue(msgBody.Row, mintColInQuantity) Then
            ShowMsg hwnd, "出库数量不能大于入库数量!", vbExclamation + vbOKOnly, Caption
            blnCancel = True
        Else
            dblQuantity = txtEdit.Value - GetValue(msgBody.Row, mintColOutQuantity)
        End If
    Case mintColOutAmount
        If txtEdit.Value > GetValue(msgBody.Row, mintColInAmount) Then
            ShowMsg hwnd, "出库金额不能大于入库金额!", vbExclamation + vbOKOnly, Caption
            blnCancel = True
        Else
            dblQuantity = GetValue(msgBody.Row, mintColInQuantity) * (txtEdit.Value - GetValue(msgBody.Row, mintColOutAmount)) / GetValue(msgBody.Row, mintColInAmount)
        End If
    End Select
    
    If Not blnCancel Then
        If mdblOutQuantity < mdblInQuantity + dblQuantity Then
            ShowMsg hwnd, "选择的出库数量之和不能大于入库数量!", vbExclamation + vbOKOnly, Caption
            blnCancel = True
        End If
    End If
End Sub

Private Sub mclsSubClassForm_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim MinMax As MINMAXINFO

    If Msg = WM_GETMINMAXINFO Then
        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        
        MinMax.ptMinTrackSize.x = mlngFormMinWidth
        MinMax.ptMinTrackSize.y = mlngFormMinHeight
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        控件方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub msgBody_Click()
    Dim lngRow As Long
    
    On Error Resume Next
    
    With msgBody
        lngRow = .MouseRow
        If .MouseCol = mintColState And lngRow < .Rows Then
            If .TextMatrix(lngRow, mintColState) <> "√" Then
                If mdblOutQuantity - mdblInQuantity > 0 Then
                    .TextMatrix(lngRow, mintColState) = "√"
                    If C2Dbl(.TextMatrix(lngRow, mintColInQuantity)) > (mdblOutQuantity - mdblInQuantity) Then
                        .TextMatrix(lngRow, mintColOutQuantity) = (mdblOutQuantity - mdblInQuantity)
                        .TextMatrix(lngRow, mintColOutAmount) = C2Dbl(.TextMatrix(lngRow, mintColOutQuantity)) * C2Dbl(.TextMatrix(lngRow, mintColInPrice))
                    ElseIf C2Dbl(.TextMatrix(lngRow, mintColInQuantity)) = (mdblOutQuantity - mdblInQuantity) Then
                        .TextMatrix(lngRow, mintColOutQuantity) = (mdblOutQuantity - mdblInQuantity)
                        .TextMatrix(lngRow, mintColOutAmount) = C2Dbl(.TextMatrix(lngRow, mintColInAmount))
                    Else
                        .TextMatrix(lngRow, mintColOutQuantity) = .TextMatrix(lngRow, mintColInQuantity)
                        .TextMatrix(lngRow, mintColOutAmount) = .TextMatrix(lngRow, mintColInAmount)
                    End If
                    mclsGrid.FormatCell lngRow, mintColOutQuantity, mintColOutAmount
                    mdblInQuantity = mdblInQuantity + C2Dbl(.TextMatrix(lngRow, mintColOutQuantity))
                End If
            Else
                If IsNumeric(.TextMatrix(lngRow, mintColOutQuantity)) Then
                    mdblInQuantity = mdblInQuantity - C2Dbl(.TextMatrix(lngRow, mintColOutQuantity))
                End If
                .TextMatrix(lngRow, mintColState) = ""
                .TextMatrix(lngRow, mintColOutQuantity) = ""
                .TextMatrix(lngRow, mintColOutAmount) = ""
            End If
        End If
    End With
            
End Sub

Private Sub msgBody_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgBody
        If .MouseCol = mintColState Then
            .MousePointer = flexCustom
        Else
            .MousePointer = flexDefault
        End If
    End With
End Sub

Private Sub cmdList_Click(index As Integer)
    Dim lngRow As Long
    Select Case index
    Case 0  '确定
        If mdblOutQuantity = mdblInQuantity Then
            SaveCostDetail
            With msgBody
                For lngRow = .FixedRows To .Rows - 1
                    If .TextMatrix(lngRow, mintColState) = "√" Then
                        frmCalcSingle.SetInDetail mlngOutID, .TextMatrix(lngRow, mintColInID), .TextMatrix(lngRow, 5), _
                            .TextMatrix(lngRow, 6), .TextMatrix(lngRow, 7), _
                            C2Dbl(.TextMatrix(lngRow, mintColOutQuantity)), C2Dbl(.TextMatrix(lngRow, mintColOutAmount))
                    End If
                Next lngRow
                Unload Me
            End With
        Else
            ShowMsg hwnd, "出入库数量不相等！", vbOKOnly + vbExclamation, Caption
        End If
    Case 1 '取消
        Unload Me
    Case 2 '关联
        mdblInQuantity = 0
        frmCalcSingle.InitCostDetail True
        RefreshGrid
    End Select
End Sub

Private Sub msgBody_RowColChange()
    With msgBody
        If .Row >= .FixedRows Then
            If .TextMatrix(.Row, mintColInID) > 0 Then
                cmdList(2).Enabled = True
            Else
                cmdList(2).Enabled = False
            End If
        Else
            cmdList(2).Enabled = False
        End If
    End With
End Sub

Private Function GetValue(ByVal lngRow As Long, ByVal intCol As Integer) As Double
    GetValue = GetGridValue(lngRow, intCol, "Double", msgBody)
End Function

Private Sub txtQuantity_GotFocus()
    On Error Resume Next
    msgBody.SetFocus
End Sub