frmcalcsingle.frm

金算盘软件代码

            For lngRow = .FixedRows To .Rows - 1
                If CLng(.TextMatrix(lngRow, mlngColOutID)) = OutID Then
                    Exit For
                End If
            Next lngRow
        End If
        If lngRow < .Rows Then
            Do While lngRow < .Rows
                If CLng(.TextMatrix(lngRow, mlngColOutID)) <> OutID Or CLng(.TextMatrix(lngRow, mlngColInID)) = InID _
                    Or CLng(.TextMatrix(lngRow, mlngColInID)) = 0 Then
                    Exit Do
                Else
                    lngRow = lngRow + 1
                End If
            Loop
            '如果没有对应的出库ID,在Grid中增加一条记录
            If lngRow >= .Rows Then
                .AddItem OutID & vbTab & 0, lngRow
            Else
                If CLng(.TextMatrix(lngRow, mlngColOutID)) <> OutID Then
                    .AddItem OutID & vbTab & 0, lngRow
                End If
            End If
            '指定出库商品的对应入库资料
            If CLng(.TextMatrix(lngRow, mlngColOutID)) = OutID And CLng(.TextMatrix(lngRow, mlngColInID)) = 0 Then
                .TextMatrix(lngRow, mlngColInID) = InID
                .TextMatrix(lngRow, 8) = strDate
                .TextMatrix(lngRow, 9) = strType
                .TextMatrix(lngRow, 10) = strNo
            End If
            .TextMatrix(lngRow, 11) = dblQuantity
            If dblQuantity <> 0 Then
                .TextMatrix(lngRow, 12) = dblAmount / dblQuantity
            Else
                .TextMatrix(lngRow, 12) = 0
            End If
            .TextMatrix(lngRow, 13) = dblAmount
            '重新格式入库数量、单价、金额的显示格式
            mclsGrid.FormatCell lngRow, 11, 13
        End If
    End With
    gclsBase.ExecSQL "UPDATE Item SET strReCalcCost='" & Format(mdtmStart, "yyyy-mm-dd") _
        & "' WHERE lngItemID=" & mlngItemID & " AND strReCalcCost>'" & Format(mdtmStart, "yyyy-mm-dd") & "'"
    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

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        私有方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'生成列表结果集
'调用查询 QItemOutSingle 查询商品成本批次
Private Function GetList() As rdoResultset
    Dim errNo As Long
    Dim strSql As String
    On Error GoTo ErrHandle
    
    strSql = "SELECT OutActivityDetail.lngActivityDetailID,NVL(ItemCostDetail.lngInActivityDetailID,0) As ID," _
            & mclsGrid.ListSet.SelectOfSql & " " _
            & mclsGrid.ListSet.FromOfSql _
            & " WHERE " & mclsGrid.ListSet.WhereOfSql
    strSql = strSql & " AND OutActivity.strDate>='" & Format(mdtmStart, "yyyy-mm-dd") & "' " _
            & "AND OutActivity.strDate<='" & Format(mdtmEnd, "yyyy-mm-dd") & "' " _
            & "AND (OutActivityDetail.dblQuantity>0 and OutActivity.lngActivityTypeID IN (11,13,16,15,19,21,22,31) " _
            & "OR OutActivityDetail.dblQuantity<0 AND OutActivity.lngActivityTypeID IN  (1,3,5,9,8,10,30,32)) " _
            & "AND OutActivityDetail.lngItemID=" & mlngItemID & " ORDER BY OutActivityDetail.lngActivityDetailID"

    Set GetList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Exit Function
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
    Set GetList = Nothing
End Function



Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 27 Then
        Unload Me
    End If
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        Form 事件、方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form_Load()
    Me.MousePointer = vbHourglass
    
    Me.HelpContextID = HelpID
    
    With picGrid
        .Visible = False
        .Left = mintLeft
        .top = mintTop
    End With
    With msgHead
        .top = 0
        .Left = 0
    End With
    With msgBody
        .top = msgHead.top + msgHead.Height
        .Left = 0
        .SelectionMode = flexSelectionByRow
    End With
    
    'Grid对象
    Set mclsGrid = New MutiGrid
    mclsGrid.ListSet.ViewId = mViewID
    
    'Form的钩子，处理窗体最小尺寸
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hWnd = Me.hWnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    
    '主控对象
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Me.MousePointer = vbDefault
End Sub

'关闭成本批次前，检查指定批次窗口是否显示
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If mblnExistChild And UnloadMode <= 1 Then
        ShowMsg hWnd, "请先关闭指定成本批次窗口!", vbOKOnly + vbExclamation, Caption
        Cancel = 1
    End If
End Sub

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

    Set mclsGrid = Nothing
    Set mclsSubClassform = Nothing
    
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub


Private Sub Form_Activate()
    
    gclsSys.CurrFormName = hWnd
    SetHelpID HelpContextID
    '如果没有初始Grid
    If mclsGrid.ListSet.ViewId = 0 Then
        mclsGrid.ListSet.ViewId = mViewID
        mblnReCalc = True
    Else
'        If mlngItemID <> frmCalcCost.msgBody.TextMatrix(frmCalcCost.msgBody.Row, 0) Then
'            mlngItemID = frmCalcCost.msgBody.TextMatrix(frmCalcCost.msgBody.Row, 0)
'            lblItem.Caption = frmCalcCost.msgBody.TextMatrix(frmCalcCost.msgBody.Row, frmCalcCost.mlngColItemCode)
'            mblnReCalc = True
'        End If
    End If
    
    If mblnReCalc Then
        Me.MousePointer = vbHourglass
        mblnReCalc = False
        msgBody.Rows = 2
        msgBody.FixedCols = 0
        
        msgBody.FixedRows = 1
        msgBody.RowHeight(0) = 0
        
        Set datItem.Resultset = GetList()
        If Not datItem.Resultset Is Nothing Then
            Set mclsGrid.Grid = msgBody
            Set mclsGrid.HeadGrid = msgHead
            mclsGrid.ColOfs = 2
            msgBody.ColWidth(1) = 0
            mclsGrid.SetupStyle
            mclsGrid.ListSetToGrid
            mclsGrid.SetTitle datItem.Resultset
            
            datItem.Resultset.Close
        Else
            msgBody.Cols = 2
        End If
        
        picGrid.Visible = True
        Me.MousePointer = vbDefault
        msgBody_RowColChange
    End If
    mclsMainControl_ChildActive
End Sub

Private Sub Form_Resize()
    Dim lngCnt As Long
    On Error Resume Next
    If WindowState <> vbMinimized Then
        If WindowState <> vbMaximized And (Left >= Screen.width Or Left + width <= 0) Then
            Left = (Screen.width - width) / 2
        End If
        cmdList(0).Left = ScaleWidth - cmdList(0).width - 2 * mintLeft
        For lngCnt = 1 To 4
            cmdList(lngCnt).Left = cmdList(0).Left
        Next lngCnt
        
        With picGrid
            .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
        lblItem.Left = ListFormLeft
        mclsGrid.FormResize
    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

'加载出库商品的入库资料（由Grid类显示刷新时自动调用）
Private Sub mclsGrid_BeforeRefresh(lngRow As Long)
    If lngRow > msgBody.FixedRows Then
        With msgBody
            If .TextMatrix(lngRow, 0) = .TextMatrix(lngRow - 1, 0) Then
                .TextMatrix(lngRow, 2) = ""
                .TextMatrix(lngRow, 3) = ""
                .TextMatrix(lngRow, 4) = ""
                .TextMatrix(lngRow, 5) = ""
                .TextMatrix(lngRow, 6) = ""
                .TextMatrix(lngRow, 7) = ""
            End If
        End With
    End If
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        控件方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmdList_Click(Index As Integer)
    Dim lngRow As Long
    Dim lngOutID As Long
    Dim lngItemID As Long
    
    Select Case Index
    Case 0  '确定
        Unload Me
    Case 1  '取消
        Unload Me
    Case 2  '关联
        If msgBody.Row < msgBody.FixedRows Then Exit Sub
    
        With msgBody
            If .Row >= .FixedRows Then
                BillPublic.ShowBill 11, .TextMatrix(.Row, mlngColOutID)
            End If
        End With
    Case 3  '选择批次
        If msgBody.Row < msgBody.FixedRows Or Not mclsGrid.RowSelected Then Exit Sub
        If Not ExclusiveIn(Caption, mclsMainControl.LogID, "不能指定批次，因为其他用户也在进行本操作！") Then Exit Sub
        If CLng(msgBody.TextMatrix(msgBody.Row, mlngColOutID)) > 0 Then
            With msgBody
                lngOutID = CLng(.TextMatrix(.Row, mlngColOutID))
                For lngRow = .Row To .FixedRows + 1 Step -1
                    If CLng(.TextMatrix(lngRow - 1, mlngColOutID)) <> lngOutID Then
                        Exit For
                    End If
                Next lngRow
                lngOutID = .TextMatrix(lngRow, mlngColOutID)
                '设置出库商品，数量
                frmCalcSingleChoice.SetParameters lngOutID, mlngItemID, _
                    lblItem.Caption, Abs(CLng(.TextMatrix(lngRow, mlngColOutQuantity)))
                '显示指定批次窗口
'                frmCalcSingleChoice.Show vbModal
            End With
        End If
    Case 4  '取消批次
        If msgBody.Row < msgBody.FixedRows Or Not mclsGrid.RowSelected Then Exit Sub
        If Not ExclusiveIn(Caption, mclsMainControl.LogID, "不能取消批次，因为其他用户也在进行本操作！") Then Exit Sub
        lngOutID = CLng(msgBody.TextMatrix(msgBody.Row, mlngColOutID))
        ClearInDetail lngOutID
    End Select
End Sub

Private Sub msgBody_Click()
    msgBody_RowColChange
End Sub

'处理命令按扭是否有效
Private Sub msgBody_RowColChange()
    Dim lngOutID As Long
    
    With msgBody
        If .RowSel >= .FixedRows And mclsGrid.RowSelected Then
            lngOutID = .TextMatrix(.RowSel, mlngColOutID)
        End If
        If lngOutID > 0 Then
            cmdList(2).Enabled = True
            cmdList(3).Enabled = True
            If .TextMatrix(.Row, mlngColInID) Then
                cmdList(4).Enabled = True
            Else
                cmdList(4).Enabled = False
            End If
        Else
            cmdList(2).Enabled = False
            cmdList(3).Enabled = False
            cmdList(4).Enabled = False
        End If
    End With
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        主控事件
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsMainControl_ChildActive()
    UpdateMenuStatu
End Sub
Private Sub UpdateMenuStatu()
    With frmMain
        .mnuEditCopy.Enabled = False
        .mnuEditEdit.Enabled = False
        .mnuEditNew.Enabled = False
        .mnuEditDel.Enabled = False
        .mnuEditInActive.Enabled = False
        .mnuEditShowAll.Checked = False
        .mnuEditShowAll.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuEditColumn.Enabled = False
        .mnuEditFilter.Enabled = False
        .mnuEditSearch.Enabled = False
        .mnuEditNotepad.Enabled = False
        .mnuEditShowList.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuFilePrint.Enabled = False
        .mnuToolRefresh.Enabled = False
        .SetToolBar
    End With
End Sub