frmtakestock.frm

金算盘软件代码

                    dtmDate1 = C2Date(lblField(2).Caption)
'                    clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate1)   '会计年度
'                    clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate1)   '会计期间
                    blnMaxNODecrease gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
                        SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
                        strDigitOfStr(LTrim(strNewReceiptNO))

                    strNewReceiptNO = lblField(1).Caption
                    NewReceiptDate = gclsBase.BaseDate
                    blnModifyMaxNO gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
                       SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
                       strDigitOfStr(LTrim(strNewReceiptNO))
                     cmdNext_Click
'                    ShowANewBill , False
                End If
            ElseIf blnBillIsClosed(33, clsBill.lngNowID) Then
               clsBill.ShowMsgOther Me.hwnd, "本张商品盘点单已经结帐，不能删除！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "删除单据"
            ElseIf clsList.DeleteStockTaking(clsBill.lngNowID, False) Then
'                clsBill.lngNowID = 0
                clsBill.blnIsChanged = False
                gclsSys.SendMessage Me.hwnd, 30 + C2lng(lblHead(2).Tag)
                dtmDate1 = C2Date(lblField(2).Caption)
'                clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate1)   '会计年度
'                clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate1)   '会计期间
'                blnMaxNODecrease gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
'                    SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
'                    strDigitOfStr(LTrim(strNewReceiptNO))

'                    strNewReceiptNO = lblField(1).Caption
'                    NewReceiptDate = gclsBase.BaseDate
'                    blnModifyMaxNO gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
'                       SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
'                       strDigitOfStr(LTrim(strNewReceiptNO))
                  clsBill.lngNowID = 0
                  cmdNext_Click
'                ShowANewBill , False
            End If
        Case 2  'BAR
        Case 3  '复制单据
            clsBill.SaveBillToCollection
        Case 4  '粘贴单据
            clsBill.LoadBillFromCollection
            reCalculate
        Case 5  'BAR
        Case 6  '搜索
            frmTreeFind.ShowFind
        Case 7  '查询缺号
            Dim frmTmp As Form
            Set frmTmp = New frmBillNo
            frmTmp.ShowTypeID C2lng(lblHead(2).Tag)
            Set frmTmp = Nothing
        Case 9  '模板表体列宽恢复
            ModifyColWidthDefault Me
            clsBill.TemplateChange C2lng(lblHead(4).Tag)
        Case 11
            CallBillList 33, True
        Case 12
            CallBillList 33, False
        Case 13
            GotoOldBill
        Case 14
            mclsMainControl_FilePrintReceipt
    End Select
    clsBill.WriteTotal
End Sub
Private Sub refTmpID_Change()
    clsBill.TemplateChange C2lng(lblHead(4).Tag)
End Sub

Private Sub SaveActivity(recTmp As rdoResultset)
    Dim strTmp As String
    With recTmp
        !blnIsPrinted = 0
        !intYear = gclsBase.FYearOfDate(C2Date(lblField(2).Caption))
        !bytPeriod = gclsBase.PeriodOfDate(C2Date(lblField(2).Caption))
        strTmp = SubStr(strAlphaOfStr(LTrim(lblField(1).Caption)), 1, 6)
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strReceiptNo = strTmp
        !lngReceiptNo = C2lng(strDigitOfStr(LTrim(lblField(1).Caption)))
        !lngTemplateID = C2lng(lblHead(5 - 1).Tag)
        BillPublic.setPrevPlateAndBillNo 33, !lngTemplateID, !strReceiptNo
        !lngClassID2 = IIf(lblField(5).Visible Or blnIsLoading, clsBill.getFieldID(5), 0)
        !lngClassID1 = IIf(lblField(6).Visible Or blnIsLoading, clsBill.getFieldID(6), 0)
        !lngDepartmentID = IIf(lblField(4).Visible Or blnIsLoading, clsBill.getFieldID(4), 0)
        !lngEmployeeID = IIf(lblField(3).Visible Or blnIsLoading, clsBill.getFieldID(3), 0)
        strTmp = lblField(2).Caption
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strDate = strTmp
        !lngOperatorID = IIf(C2lng(LblMemo(LblMemo.Count - 1).Tag) > 0, C2lng(LblMemo(LblMemo.Count - 1).Tag), gclsBase.OperatorID)
        Dim strT As String
        strT = Trim(LblMemo(1).Caption)
        strTmp = IIf(StrLen(strT) < 40, strT, SubStr(strT, 1, 40))
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strNote = strTmp
        !blnIsPrint = chkPrint(0).Value
        !blnIsVoid = chkPrint(1).Value
    End With
End Sub
Private Sub SaveActivityDetailBody(recTmp As rdoResultset, ByVal i As Integer)
    Dim strTmp As String
    Dim dblFactor As Double
    With recTmp
        !lngRowID = i
        !lngItemID = C2lng(clsBill.strGrdCell(i, 20))
        !lngUnitID = C2lng(clsBill.strGrdCell(i, 21))
        dblFactor = ConvertFactor(!lngUnitID, !lngItemID)
        !lngPositionID = C2lng(clsBill.strGrdCell(i, 19))
        !dblAccountQuantity = C2Dbl(NumberConvert(clsBill.strGrdCell(i, xlngColNo(5)), dblFactor, True))
        !dblStockQuantity = C2Dbl(NumberConvert(clsBill.strGrdCell(i, xlngColNo(6)), dblFactor, True))
        strTmp = clsBill.strGrdCell(i, xlngColNo(9))
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strProduceNum = strTmp
        strTmp = clsBill.strGrdCell(i, xlngColNo(10))
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strProduceDate = strTmp
        strTmp = clsBill.strGrdCell(i, xlngColNo(11))
        strTmp = IIf(strTmp = "", " ", strTmp)
        !strValidDate = strTmp
        !intValidDay = IIf(IsNull(clsBill.strGrdCell(i, xlngColNo(12))), 0, CInt(C2lng(clsBill.strGrdCell(i, xlngColNo(12)))))
        !lngCustomID0 = C2lng(clsBill.strGrdCell(i, 23))
        !lngCustomID1 = C2lng(clsBill.strGrdCell(i, 24))
        !lngCustomID2 = C2lng(clsBill.strGrdCell(i, 25))
        !lngCustomID3 = C2lng(clsBill.strGrdCell(i, 26))
        !lngCustomID4 = C2lng(clsBill.strGrdCell(i, 27))
        !lngCustomID5 = C2lng(clsBill.strGrdCell(i, 28))
        !blnIsWizrad = IIf((Trim(clsBill.strGrdCell(i, 30)) = ""), 0, 1)
        !lngInOutActivityDetailID = C2lng(GrdCol.TextMatrix(i, 31))
'        !strRemark = grdCol.TextMatrix(i, xlngColNo(1)) + " "                               '备注
        '设已存储标志
        GrdCol.TextMatrix(i, 0) = !lngStockTakingDetailID
    End With
End Sub
Private Function SaveNewBill() As Boolean
    Dim recActivity As rdoResultset
    Dim recDetail As rdoResultset
    Dim lngNewActivityID As Long
    Dim dtmDate1 As Date
    Dim strAlpha As String
    Dim lngDigit As Long
    Dim i As Long
    Dim blnTransBegin As Boolean    '错误处理中是否作事务回滚标志
    Dim strTmp As String
    #If conDebug Then
    #Else
        On Error GoTo ErrorHandle
    #End If
    
    Dim recTemp As rdoResultset
    '制单日合法性校验
    If gclsBase.PeriodClosed(lblField(2).Caption) Then
        clsBill.ShowMsgOther Me.hwnd, "制单日不能在已结帐期间内！", MB_ICONEXCLAMATION + MB_OK + MB_SYSTEMMODAL, "保存单据"
        lblField(2).Caption = Format(gclsBase.BaseDate, "yyyy-mm-dd")
        SaveNewBill = False
        Exit Function
    End If

    If clsBill.blnIsChanged = False Then
        SaveNewBill = True
        Exit Function
    Else
        SaveNewBill = False
    End If
    If clsBill.DataValid() = False Then
        Exit Function
    End If
    Me.MousePointer = vbHourglass
SaveStart:
    gclsBase.BaseWorkSpace.BeginTrans
    blnTransBegin = True
    Set recActivity = gclsBase.BaseDB.OpenResultset( _
            "SELECT * FROM StockTaking WHERE ROWNUM < 1", rdOpenDynamic, rdConcurValues)
    If recActivity Is Nothing Then
        gclsBase.BaseWorkSpace.RollBacktrans
        GoTo EndProc
    End If
    With recActivity
        .AddNew
            lngNewActivityID = GetNewID("StockTaking")
            !lngStockTakingID = lngNewActivityID
            SaveActivity recActivity
            '取出重用信息
            dtmDate1 = !strDate
            strAlpha = !strReceiptNo
            lngDigit = !lngReceiptNo
        .Update
        '设置已存储(修改)标志
        clsBill.lngNowID = lngNewActivityID
            
    End With
'    clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate1)   '会计年度
'    clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate1)   '会计期间
'    '修改最大编号表
'    If blnModifyMaxNO(clsBill.intAccountYear, clsBill.bytAccountPeriod, _
'                C2Lng(lblHead(3 - 1).Tag), strAlpha, CStr(lngDigit)) = False Then
'        gclsBase.BaseWorkSpace.RollBacktrans
'        clsBill.lngNowID = 0
'        For i = 1 To grdCol.Rows - 1
'            grdCol.TextMatrix(i, 0) = 0
'        Next i
'        GoTo EndProc
'    End If
    '修改明细表
    Set recDetail = gclsBase.BaseDB.OpenResultset( _
            "SELECT * FROM StockTakingDetail WHERE ROWNUM < 1", _
            rdOpenDynamic, rdConcurValues)
    With recDetail
        If GrdCol.Rows >= 2 Then
            For i = 1 To GrdCol.Rows - 1
                If clsBill.blnNotNullRow(i) Then
                    .AddNew
                        !lngStockTakingID = lngNewActivityID
                        !lngStockTakingDetailID = GetNewID("StockTakingDetail")
                        GrdCol.TextMatrix(i, 0) = !lngStockTakingDetailID
                        SaveActivityDetailBody recDetail, i
                    .Update
                End If
            Next i
        End If
    End With
'    '修改最大编号表
'    If strNewReceiptNO <> LblField(1).Caption Or NewReceiptDate <> C2Date(LblField(2).Caption) Then
'        If blnMaxNODecrease(gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(LblHead(2).Tag), _
'            SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
'            strDigitOfStr(LTrim(strNewReceiptNO))) = False Then
'            gclsBase.BaseWorkSpace.RollBacktrans
'            clsBill.lngNowID = 0
'            For i = 1 To GrdCol.Rows - 1
'                GrdCol.TextMatrix(i, 0) = 0
'            Next i
'            GoTo EndProc
'        End If
'    End If
'    '修改最大编号表
'    If blnModifyMaxNO(clsBill.intAccountYear, clsBill.bytAccountPeriod, _
'                C2lng(LblHead(3 - 1).Tag), strAlpha, CStr(lngDigit)) = False Then
'        gclsBase.BaseWorkSpace.RollBacktrans
'        clsBill.lngNowID = 0
'        For i = 1 To GrdCol.Rows - 1
'            GrdCol.TextMatrix(i, 0) = 0
'        Next i
'        GoTo EndProc
'    End If
    blnTransBegin = False
    gclsBase.BaseWorkSpace.CommitTrans
    
    '修改最大编号表
    If strNewReceiptNO <> lblField(1).Caption Or NewReceiptDate <> C2Date(lblField(2).Caption) Then
        If blnMaxNODecrease(gclsBase.FYearOfDate(NewReceiptDate), gclsBase.PeriodOfDate(NewReceiptDate), C2lng(lblHead(2).Tag), _
            SubStr(strAlphaOfStr(LTrim(strNewReceiptNO)), 1, 6), _
            strDigitOfStr(LTrim(strNewReceiptNO))) = False Then
'            gclsBase.BaseWorkSpace.RollBacktrans
'            clsBill.lngNowID = 0
'            For i = 1 To GrdCol.Rows - 1
'                GrdCol.TextMatrix(i, 0) = 0
'            Next i
'            GoTo EndProc
        End If
    End If
    '修改最大编号表
    If blnModifyMaxNO(clsBill.intAccountYear, clsBill.bytAccountPeriod, _
                C2lng(lblHead(3 - 1).Tag), strAlpha, CStr(lngDigit)) = False Then
'        gclsBase.BaseWorkSpace.RollBacktrans
'        clsBill.lngNowID = 0
'        For i = 1 To GrdCol.Rows - 1
'            GrdCol.TextMatrix(i, 0) = 0
'        Next i
'        GoTo EndProc
    End If
    
    setPrevPlateAndBillNo 33, C2lng(lblHead(4).Tag), SubStr(strAlphaOfStr(LTrim(lblField(1).Caption)), 1, 6)
    chkPrint(1).Enabled = True
    clsBill.blnIsChanged = False
    gclsSys.SendMessage Me.hwnd, 30 + C2lng(lblHead(2).Tag)
    SaveNewBill = True
EndProc:
    If Not recActivity Is Nothing Then
        recActivity.Close
    End If
    If Not recDetail Is Nothing Then
        recDetail.Close
    End If
    Me.MousePointer = vbDefault
    Screen.MousePointer = vbDefault
    Exit Function

ErrorHandle:
    Dim lngErrNO As Long
    Dim strErr As String
    
    lngErrNO = Err.Number
    strErr = Err.Description
    
    clsBill.lngNowID = 0
    For i = 1 To GrdCol.Rows - 1
      GrdCol.TextMatrix(i, 0) = 0
    Next

    If InStr(UCase(strErr), "NOUNIQUE") <> 0 Then
        If Not recActivity Is Nothing Then
            recActivity.Close
            Set recActivity = Nothing
        End If
        gclsBase.BaseWorkSpace.RollBacktrans
        If gclsBase.AutoNo And Me.Visible Then
            If clsBill.GetNextNO() Then
                Resume SaveStart
            End If
        End If
        clsBill.ShowMsgOther Me.hwnd, "单据号重复，不能存盘！", MB_OK + MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "存盘失败"
        SaveNewBill = False
        GoTo EndProc
    ElseIf lngErrNO = 3201 Then
      If InStr(UCase(strErr), "ITEM") <> 0 Then
         strTmp = "商品"
      ElseIf InStr(UCase(strErr), UCase("Template")) <> 0 Then
         strTmp = "模板"
      ElseIf InStr(UCase(strErr), UCase("Operator")) <> 0 Then
         strTmp = "操作员"
      End If
      gclsBase.BaseWorkSpace.RollBacktrans
      clsBill.ShowMsgOther Me.hwnd, strTmp & "选择错误，不能存盘！", MB_OK + MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "存盘失败"
      SaveNewBill = False
      GoTo EndProc
    End If
    If blnTransBegin Then
        gclsBase.BaseWorkSpace.RollBacktrans
    End If
    Dim edtBill As ErrDealType
    
    clsBill.lngNowID = 0
    For i = 1 To GrdCol.Rows - 1
        GrdCol.TextMatrix(i, 0) = 0
    Next i
    
    edtBill = Errors.ErrorsDeal
    clsBill.ShowMsgOther Me.hwnd, "单据保存失败！ ", MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "保存单据"
    If edtBill = edtResume Then
       Resume EndProc
    End If
    If edtBill = edtCanNotKnown Then
       Resume EndProc
    End If
    If edtBill = edtCanNotResume Then
       Resume EndProc
    End If
    If edtBill = edtResumeNext Then
       Resume EndProc
    End If
    Resume EndProc

End Function
Private Function SaveModifyBill(ByVal lngOldActivityID As Long) As Boolean
    Dim recActivity As rdoResultset
    Dim recDetail As rdoResultset
    Dim dtmDate1 As Date
    Dim strAlpha As String
    Dim lngDigit As Long
    Dim i As Integer
    Dim blnDelete As Boolean
    Dim blnTransBegin As Boolean    '错误处理中