frmprojectcost.frm

金算盘软件代码

Private Sub gspEdit_LostFocus()
'在gspEdit控件失去焦点时响应的事件
    If Val(gspEdit.Text) > 9999 Then
        gspEdit.Text = 9999
    End If
    gspEdit.Text = Val(gspEdit.Text)
End Sub

Private Sub mclsGrid1_BeforeEdit(blnCancel As Boolean)
    If msgGrid.Row = 0 Then
        Set mclsGrid1.EditText = Nothing
    Else
        Set mclsGrid1.EditText = txtEdit
    End If
End Sub

Private Sub mclsGrid1_BeforeSave(blnCancel As Boolean)
'离开TEXT输入框存盘前响应的动作
    Call SumGrid(Val(txtEdit.Text))
End Sub

Private Sub mclsGrid1_DataValid(blnCancel As Boolean)
'离开TEXT输入框时响应的事件
    Dim j As Integer
    Dim blnIsEdit As Boolean
    
    blnIsEdit = False
    With msgGrid
        If .TextMatrix(0, .col) = "本次开单" Then
            If Val(txtEdit.Text) > Val(.TextMatrix(.Row, 2)) Then
                blnCancel = True
                ShowMsg Me.hwnd, "本次开单金额不能大于未开单金额", vbInformation, Me.Caption
                txtEdit.Text = .TextMatrix(.Row, 2)
            End If
            mlngCol = .col
            blnIsEdit = True
            txtEdit.Text = Format(txtEdit.Text, "###,###,###.00")
        End If
'        If Val(.TextMatrix(.Row, .col)) > 0 Or (Val(.TextMatrix(.Row, .col)) = 0 And Val(txtEdit.Text) > 0) And blnIsEdit Then
'            .TextMatrix(.Row, 6) = ""
'        End If
        If CDbl(txtEdit.Text) <> 0 Then
           .TextMatrix(.Row, 6) = "√"
        Else
           .TextMatrix(.Row, 6) = ""
        End If
    End With
End Sub

'鼠标单击Grid响应的事件
Private Sub msgGrid_Click()
Dim i As Integer, p As Integer
Dim m As Integer, n As Integer, XX As Double, temp As Double
'On Error GoTo Err

    ytextRow = msgGrid.Row
    ytextCol = msgGrid.col
    If ytextRow > 0 And ytextRow < msgGrid.Rows Then
         i = intfixl + 1
         p = i
        '本循环找出本次调拨所在的列
        While (msgGrid.TextMatrix(0, i) <> "本次开单")
               i = i + 1
        Wend
        While (msgGrid.TextMatrix(0, p) <> "关闭")
               p = p + 1
        Wend
        If (msgGrid.TextMatrix(0, 6) = "选择") And (msgGrid.MouseCol = 6) Then
           If (msgGrid.TextMatrix(ytextRow, 6) = "") And (msgGrid.TextMatrix(ytextRow, p) <> "√") Then          '打√情况
               msgGrid.TextMatrix(ytextRow, 6) = "√"
               XX = getnumber(ytextRow, 2) - getnumber(ytextRow, i)
               msgGrid.TextMatrix(ytextRow, i) = msgGrid.TextMatrix(ytextRow, 2)
                              '总结算金额及数量的更新
               hlb(i).Caption = CStr(CDbl(IIf(Len(hlb(i).Caption) = 0, "0", hlb(i).Caption)) + XX)
           Else
               If (msgGrid.TextMatrix(ytextRow, p) <> "√") Then
                    msgGrid.TextMatrix(ytextRow, 6) = ""       '取消打√(结算)情况
                    hlb(i).Caption = CStr(CDbl(hlb(i).Caption) - getnumber(ytextRow, i))
                    msgGrid.TextMatrix(ytextRow, i) = ""
               End If
           End If
       Else
        With msgGrid
            If .TextMatrix(0, .col) = "关闭" And (msgGrid.MouseCol = p) Then
                If .TextMatrix(ytextRow, .col) = "" Then
                   .TextMatrix(ytextRow, 6) = ""
                    XX = 0 - getnumber(ytextRow, i)
                    msgGrid.TextMatrix(ytextRow, i) = ""
                    hlb(i).Caption = CStr(CDbl(IIf(Len(hlb(i).Caption) = 0, "0", hlb(i).Caption)) + XX)
        '               'hLb(i).Caption = Format((CDbl(hLb(i).Caption) + xx), "###,###,##0.00")
                    .TextMatrix(ytextRow, .col) = "√"
                Else
                    .TextMatrix(ytextRow, .col) = ""
                End If
            End If
        End With
       End If
    End If
End Sub

Private Sub msgGrid_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'鼠标在Grid上移动响应的事件
    Dim intLong As Integer
    With msgGrid
        intLong = Balance.CheckColsedCol(msgGrid, .LeftCol, mintCloseCol)
        If (X < .ColWidth(6) And Y < .Rows * .RowHeight(0) And Y > .RowHeight(0)) Or (X < intLong And Y < .Rows * .RowHeight(0) And X > intLong - .ColWidth(mintCloseCol) And Y > .RowHeight(0)) Then
            .MousePointer = vbCustom
        Else
            .MousePointer = vbDefault
        End If
    End With
End Sub
'确定
Private Sub FinishGrid(isOk As Boolean)
'按‘确定’按钮响应的存盘动作
'isOk=True， 表示存盘后退出窗体；
'isOk=False，表示存盘后不退出窗体；
    Dim dblValue As Double
    Dim strSql As String
    Dim i As Integer
    Dim j As Integer
    Dim blnIsOK As Boolean
    Dim recRecordset As Recordset
    Dim recOneToOther As Recordset
    Dim qrf As QueryDef
    Dim lngID As Long
    With msgGrid
        'Grid为空则退出
        If .Rows = 1 Then
            Exit Sub
        End If
        '查找本次开单列
        j = 6
'        MousePointer = vbHourglass
        Do While j < .Cols
            If Trim(.TextMatrix(0, j)) = "本次开单" Then
                Exit Do
            End If
            j = j + 1
        Loop
'        Strsql = "SELECT PurchaseToBill.* FROM (ItemActivity INNER JOIN ItemActivityDetail ON " _
'            & "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID) INNER JOIN PurchaseToBill" _
'            & " ON ItemActivityDetail.lngActivityDetailID = PurchaseToBill.lngSaleActivityDetailID " _
'            & "Where ItemActivity.lngActivityID = " & mlngID
'        On Error GoTo Errors1
'        Set qrf = gclsBase.BaseDB.CreateQueryDef("qrf_Calc_Ditail", Strsql)
'        On Error GoTo 0
'        Strsql = "UPDATE qrf_Calc_Ditail,ItemActivityDetail SET ItemActivityDetail.dblCurrBillAmount" _
'            & "=ItemActivityDetail.dblCurrBillAmount-qrf_Calc_Ditail.dblCurrAmount WHERE " _
'            & "ItemActivityDetail.lngActivityDetailID=qrf_Calc_Ditail.lngPurchaseActivityDetailID"
'        gclsBase.BaseDB.Execute Strsql
'        qrf.Close
'        Set qrf = Nothing
'        gclsBase.BaseDB.QueryDefs.Delete "qrf_Calc_Ditail"
'        Strsql = "DELETE PurchaseToBill.* FROM PurchaseToBill INNER JOIN (ItemActivity INNER JOIN " _
'            & "ItemActivityDetail ON ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID) " _
'            & "ON PurchaseToBill.lngSaleActivityDetailID = ItemActivityDetail.lngActivityDetailID" _
'            & " WHERE ItemActivity.lngActivityID=" & mlngID
'        gclsBase.BaseDB.Execute Strsql
        strSql = "SELECT ItemActivityDetail.dblCurrBillAmount," _
            & "ItemActivityDetail.lngActivityDetailID,ItemActivityDetail.dblSettlementQuantity" _
            & " FROM (ItemActivityDetail INNER JOIN ItemActivity ON ItemActivity.lngActivityID" _
            & "=ItemActivityDetail.lngActivityID) INNER JOIN ActivityType ON " _
            & "ActivityType.lngActivityTypeID=ItemActivity.lngActivityTypeID"
        Set recRecordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenDynaset)
        If recRecordset.EOF Then
            MousePointer = vbDefault
            Unload Me
            Exit Sub
        Else
            recRecordset.MoveLast
            recRecordset.MoveFirst
        End If
        i = 1
        '开始事务
        gclsBase.BaseWorkSpace.BeginTrans
        '写Grid
        Call Balance.WriteSaleOrPurchaseGrid(msgGrid, ToFormName.grdCol, True, j, gspEdit.Text, 5, ToFormName)
        '调用存盘函数
        If ToFormName.grdCol.Rows > 1 Then
          If Not ToFormName.SaveBill() Then
            MousePointer = vbDefault
            ShowMsg Me.hwnd, "销售单录入有误，请修改", vbInformation, Me.Caption
            Unload Me
            Exit Sub
          End If
        End If
'        If isOk = True Then
        strSql = "SELECT PurchaseToBill.* FROM (ItemActivity INNER JOIN ItemActivityDetail ON " _
            & "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID) INNER JOIN PurchaseToBill" _
            & " ON ItemActivityDetail.lngActivityDetailID = PurchaseToBill.lngSaleActivityDetailID " _
            & "Where ItemActivity.lngActivityID = " & mlngID
        On Error GoTo Errors1
        Set qrf = gclsBase.BaseDB.CreateQueryDef("qrf_Calc_Ditail", strSql)
        On Error GoTo 0
        strSql = "UPDATE qrf_Calc_Ditail,ItemActivityDetail SET ItemActivityDetail.dblCurrBillAmount" _
            & "=ItemActivityDetail.dblCurrBillAmount-qrf_Calc_Ditail.dblCurrAmount WHERE " _
            & "ItemActivityDetail.lngActivityDetailID=qrf_Calc_Ditail.lngPurchaseActivityDetailID"
'        gclsBase.BaseDB.Execute Strsql
        blnIsOK = gclsBase.ExecSQL(strSql)
        qrf.Close
        Set qrf = Nothing
        gclsBase.BaseDB.QueryDefs.Delete "qrf_Calc_Ditail"
        strSql = "DELETE PurchaseToBill.* FROM PurchaseToBill INNER JOIN (ItemActivity INNER JOIN " _
            & "ItemActivityDetail ON ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID) " _
            & "ON PurchaseToBill.lngSaleActivityDetailID = ItemActivityDetail.lngActivityDetailID" _
            & " WHERE ItemActivity.lngActivityID=" & mlngID
 '       gclsBase.BaseDB.Execute Strsql
          blnIsOK = gclsBase.ExecSQL(strSql)
        Do While i < .Rows
            '写对照表
            strSql = ""
            dblValue = 0
            lngID = Balance.GetSalePurchaseItemID(ToFormName.grdCol, Val(.TextMatrix(i, 0)))
            If .TextMatrix(i, 6) = "√" Then
                dblValue = C2Dbl(.TextMatrix(i, j))
                If Val(Trim(.TextMatrix(i, j))) <> 0 Then
                    strSql = "INSERT INTO PurchaseToBill (lngPurchaseActivityDetailID" _
                        & ",lngSaleActivityDetailID,dblCurrAmount) Values(" _
                        & .TextMatrix(i, 0) & "," & lngID & "," & dblValue & ")"
'                    dblValue = C2Dbl(.TextMatrix(i, j))
                    blnIsOK = gclsBase.ExecSQL(strSql)
                End If
'            Else
'                Strsql = "INSERT INTO PurchaseToBill (lngPurchaseActivityDetailID" _
'                    & ",lngSaleActivityDetailID,dblCurrAmount) Values(" _
'                    & .TextMatrix(i, 0) & "," & lngID & "," & Val(Trim(.TextMatrix(i, 2))) & ")"
'                dblValue = Val(Trim(.TextMatrix(i, 2)))
'            End If
'            If Len(Strsql) > 0 Then
'                gclsBase.BaseDB.Execute Strsql
'            End If
            '写商品业务明细表表
'            If dblValue > 0 Then
                recRecordset.FindFirst "lngActivityDetailID=" & .TextMatrix(i, 0)
                recRecordset.Edit
                recRecordset!dblCurrBillAmount = recRecordset!dblCurrBillAmount _
                    + dblValue
                recRecordset.Update
            End If
            i = i + 1
        Loop
 '       End If
        gclsBase.BaseWorkSpace.CommitTrans
    End With
    MousePointer = vbDefault
    If isOk = True Then
       Unload Me
    End If
    Exit Sub
Errors1:
    MousePointer = vbDefault
    gclsBase.BaseDB.QueryDefs.Delete "qrf_Calc_Ditail"
    Set qrf = gclsBase.BaseDB.CreateQueryDef("qrf_Calc_Ditail", strSql)
    Resume Next
End Sub
'计算合计
Private Sub SumGrid(dblText As Double)
    Dim i As Integer
    Dim dblValue As Double
    i = 1
    dblValue = 0
    If mlngCol > 0 Then
        With msgGrid
            Do While i < .Rows
                dblValue = dblValue + Val(Format(.TextMatrix(i, mlngCol), "#.00"))
                i = i + 1
            Loop
            hlb(mlngCol) = dblValue + dblText - Val(.TextMatrix(.Row, mlngCol))
        End With
        mlngCol = 0
    End If
End Sub