frmadjustcost2.frm

金算盘软件代码

Private Sub lblNote_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not blnEdit Then Exit Sub
    If Index < 2 Then Exit Sub
    Select Case Button
        Case vbRightButton
            clsBill.bytRegion = FNote
            clsBill.bytIndex = Index
            clsBill.UpdateMainEditMenu
            MakeListEditMenu
            PopupMenu frmMain.mnuListEdit
            Exit Sub
        Case vbLeftButton
            If Index = 3 Or Index = 5 Then
                    If x >= lblNote(Index).Width - clsBill.DropButtonWidth And _
                       x <= lblNote(Index).Width And _
                       y >= 0 And _
                       y <= lblNote(Index).Height Then
                        clsBill.Note_Click Index, True
                    Else
                        clsBill.Note_Click Index, False
                    End If
            Else
                clsBill.Note_Click Index
            End If
'            clsBill.UpdateMainEditMenu
    End Select
End Sub


Private Sub mclsMainControl_ListActivityMenu(ByVal intIndex As Integer)
    Dim strMsg(5) As String, strMsg1(5) As String
    Dim intYesNo As Integer
    Dim i%, j%
    strMsg1(0) = "您确实要删除该条委托代销调价单的分录吗？"
    strMsg1(1) = "您确实要删除该条已经作废委托代销调价单的分录吗？"
    strMsg1(3) = "该张委托代销调价单已经生成记帐凭证，不能删除其中的分录！"
    strMsg1(4) = "该张委托代销调价单已经生成记帐凭证，不能修改其中的分录！"
    Select Case intIndex
        
        Case 0  '插入记录
            clsBill.InsertARow
        Case 1  '删除记录
'            If clsBill.lngNowID <> 0 Then
'                If clsLst.IsVoucher(clsBill.lngNowID) Then
'                    ShowMsg Me.hwnd, strMsg1(3), MB_ICONQUESTION + MB_DEFBUTTON1 + MB_SYSTEMMODAL, "删除分录"
'                    Exit Sub
'                End If
'            End If
            If IsVoucher_ItemActivity(clsBill.lngNowID) > 0 Then
                ShowMsg Me.hwnd, strMsg1(3), MB_OK + MB_ICONEXCLAMATION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除分录"
                Exit Sub
            End If
            If chkPrint(1).Value = 1 Then
                intYesNo = ShowMsg(Me.hwnd, strMsg1(1), MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除分录")
            Else
                intYesNo = ShowMsg(Me.hwnd, strMsg1(0), MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除分录")
            End If
            If intYesNo = IDYES Then
                clsBill.blnCtrlBinding = False
'                If Not clsBill.blnDeleteARow(grdCol.Row) Then
'                    ShowMsg Me.hWnd, "删除当前记录失败！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL
'                    Exit Sub
'                End If
                If grdCol.Row >= 1 And grdCol.Rows > 2 Then
                    grdCol.RemoveItem grdCol.Row
                    clsBill.setAllItemproperty
                    grdCol.col = xlngColItem
                ElseIf grdCol.Row = 1 Then
                    clsBill.InsertARow True
                    grdCol.RemoveItem 2
                    grdCol.col = xlngColItem
                    clsBill.setAllItemproperty
                End If
                clsBill.blnCtrlBinding = True
                clsBill.grdCol_EnterCell
                clsBill.BuildNoteMsg True
                For i% = 1 To grdCol.Cols - 1
                    If grdCol.ColAlignment(i%) = 7 Then lblTotal(i%).Caption = CStr(clsBill.dblTotalOfCol(i%))
                Next i%
                                
           End If
        Case 2  'bar
        Case 3  '复制记录
            clsBill.CopyARow
        Case 4  '粘贴记录
            clsBill.PasteARow
        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
    End Select
    '合计行计算
    clsBill.writeTotal
End Sub

Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
    Dim strMsg(5) As String
    Dim intYesNo As Integer
    Dim i%, j%
    strMsg(0) = "您确实要删除该张委托代销调价单的全部分录吗？"
    strMsg(1) = "您确实要删除该张已经作废委托代销调价单的全部分录吗？"
    strMsg(3) = "该张委托代销调价单已经生成记帐凭证，不能删除！"
    strMsg(4) = "该张委托代销调价单已经生成记帐凭证，不能修改！"
    Select Case intIndex
       
        Case 0  '插入单据
'            clsBill.GetANewBill lblHead(5 - 1).Tag, lblHead(3 - 1).Tag, lblField(1).Caption
            ShowANewBill
        Case 1  '删除单据
'            If clsLst.IsVoucher(clsBill.lngNowID) Then
'                ShowMsg Me.hwnd, strMsg(3), MB_ICONQUESTION + MB_DEFBUTTON1 + MB_SYSTEMMODAL, "删除委托代销调价单"
'                Exit Sub
'            End If
            If IsVoucher_ItemActivity(clsBill.lngNowID) > 0 Then
                ShowMsg Me.hwnd, strMsg(3), MB_OK + MB_ICONEXCLAMATION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除分录"
                Exit Sub
            End If
            If chkPrint(1).Value = 1 Then
                intYesNo = ShowMsg(Me.hwnd, strMsg(1), MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除委托代销调价单")
            Else
                intYesNo = ShowMsg(Me.hwnd, strMsg(0), MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "删除委托代销调价单")
            End If
            If intYesNo = IDYES Then
                strSql = "DELETE * FROM ItemActivity WHERE lngActivityID=" & clsBill.lngNowID
                gclsBase.BaseDB.Execute strSql
                strSql = "DELETE * FROM ItemActivityDetail WHERE lngActivityID=" & clsBill.lngNowID
                gclsBase.BaseDB.Execute strSql

                Dim dtmDate1 As Date
                dtmDate1 = C2Date(lblField(2).Caption)
                clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate1)   '会计年度
                clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate1)   '会计期间
                blnMaxNODecrease clsBill.intAccountYear, clsBill.bytAccountPeriod, C2Lng(lblHead(2).Tag), strAlphaOfStr(lblField(1).Caption), C2Lng(strDigitOfStr(lblField(1).Caption))
                clsBill.lngNowID = 0
                clsBill.blnIsChanged = False
                gclsSys.SendMessage Me.hwnd, 30 + C2Lng(lblHead(2).Tag)
                ShowANewBill
            End If
        Case 2  'BAR
        Case 3  '复制单据
            clsBill.SaveBillToCollection
        Case 4  '粘贴单据
            clsBill.LoadBillFromCollection
        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
    End Select
    '合计行计算
    clsBill.writeTotal
End Sub
Private Sub refTmpID_Change()
    clsBill.TemplateChange C2Lng(lblHead(4).Tag)
End Sub

Private Sub SaveActivity(recTmp As Recordset)
    With recTmp
        !lngActivityTypeID = ReceiptType2ActivityType(C2Lng(lblHead(3 - 1).Tag))
        !lngReceiptTypeID = C2Lng(lblHead(3 - 1).Tag)
        !strReceiptNo = SubStr(strAlphaOfStr(LTrim(lblField(1).Caption)), 1, 6)
        !lngReceiptNo = C2Lng(strDigitOfStr(LTrim(lblField(1).Caption)))
        !lngTemplateID = C2Lng(lblHead(5 - 1).Tag)
        BillPublic.setPrevPlateAndBillNo !lngReceiptTypeID, !lngTemplateID, !strReceiptNo
        !lngCustomerID = IIf(lblHead(1).Visible, C2Lng(lblHead(1 - 1).Tag), 0)
        !lngDepartmentID = IIf(lblField(4).Visible, clsBill.getFieldID(4), 0)
        !lngEmployeeID = IIf(lblField(3).Visible, clsBill.getFieldID(3), 0)
        !lngClassID2 = IIf(lblField(7).Visible, clsBill.getFieldID(7), 0)
        !lngClassID1 = IIf(lblField(8).Visible, clsBill.getFieldID(8), 0)
        !lngCurrencyID = IIf(lblField(6).Visible, clsBill.getFieldID(6), 0)
        !dblRate = IIf(lblField(5).Visible, C2Dbl(lblField(5).Caption), 1)
        !strDate = lblField(2).Caption
        !lngOperatorID = gclsBase.OperatorID
        Dim strT As String
        strT = lblmemo(1).Caption
        !strNote = IIf(strLen(strT) < 40, strT + " ", SubStr(strT, 1, 40))
        !blnIsPrint = IIf(chkPrint(0).Value = 0, False, True)
        !blnIsVoid = IIf(chkPrint(1).Value = 0, False, True)
    End With
End Sub
Private Sub SaveActivityDetailBody(recTmp As Recordset, ByVal i As Integer)
    Dim arrItemProperty As ItemProperty
    Dim strSql As String
    Dim dblFactor As Double
    
    BillPublic.GetItemProperty C2Lng(grdCol.TextMatrix(i, xlngColItemID)), arrItemProperty
    With recTmp
        !lngRowID = i
        !lngItemID = C2Lng(clsBill.strGrdCell(i, xlngColItemID))
        !lngUnitID = C2Lng(clsBill.strGrdCell(i, xlngColItemUnitID))
        dblFactor = ConvertFactor(!lngUnitID, !lngItemID)
        !dblCurrPrice = Format(C2Dbl(clsBill.strGrdCell(i, xlngColCurOldPrice)) / dblFactor, FormatString(gclsBase.PriceDec))
        !dblCurrNewPrice = Format(C2Dbl(clsBill.strGrdCell(i, xlngColCurPrice)) / dblFactor, FormatString(gclsBase.PriceDec))
        !dblQuantity = C2Dbl(NumberConvert(clsBill.strGrdCell(i, xlngColNumber), dblFactor, True))
        !dblCurrAmount = C2Dbl(clsBill.strGrdCell(i, xlngColCurAmount))
        !dblAmount = C2Dbl(clsBill.strGrdCell(i, xlngColAmount))
        !lngTaxID = C2Lng(clsBill.strGrdCell(i, xlngColTaxID))
        !dblCurrTaxAmount = C2Dbl(clsBill.strGrdCell(i, xlngColCurTaxAmount))
        !dblTaxAmount = C2Dbl(clsBill.strGrdCell(i, xlngColTaxAmount))
        !lngJobID = C2Lng(clsBill.strGrdCell(i, xlngColJobID))
        !lngCustomID0 = C2Lng(clsBill.strGrdCell(i, xlngColCustom0ID))
        !lngCustomID1 = C2Lng(clsBill.strGrdCell(i, xlngColCustom1ID))
        !lngCustomID2 = C2Lng(clsBill.strGrdCell(i, xlngColCustom2ID))
        !lngCustomID3 = C2Lng(clsBill.strGrdCell(i, xlngColCustom3ID))
        !lngCustomID4 = C2Lng(clsBill.strGrdCell(i, xlngColCustom4ID))
        !lngCustomID5 = C2Lng(clsBill.strGrdCell(i, xlngColCustom5ID))
        If chkPrint(1).Value <> 1 Then
            Dim priceTmp1 As Double
            Dim priceTmp2 As Double
    
            Select Case arrItemProperty.strCostMethod
                Case "7"
                priceTmp1 = C2Dbl(clsBill.strGrdCell(i, xlngColPrice))
    '            priceTmp2 = (priceTmp1 / (1 + TaxIDToRate(!lngTaxID))) / dblFactor
                priceTmp2 = C2Dbl(Format(priceTmp1 / dblFactor, FormatString(gclsBase.PriceDec)))
                strSql = "UPDATE Item SET dblSalePrice = " & priceTmp2 _
                    & ",dblMaxSalePrice=IIF(dblMaxSalePrice>" & priceTmp2 & ",dblMaxSalePrice, " & priceTmp2 _
                    & "),dblMinSalePrice=IIF(dblMinSalePrice<" & priceTmp2 & ",dblMinSalePrice, " & priceTmp2 _
                    & "),dblRecenetSalePrice=" & priceTmp2 _
                    & " WHERE lngItemId = " & C2Lng(clsBill.strGrdCell(i, xlngColItemID))
            Case "6"
                priceTmp1 = C2Dbl(clsBill.strGrdCell(i, xlngColPrice))
                priceTmp2 = priceTmp1 / dblFactor
                strSql = "UPDATE Item SET dblPlanPrice = " & priceTmp2 _
                    & " WHERE lngItemId = " & C2Lng(clsBill.strGrdCell(i, xlngColItemID))
            Case Else
                priceTmp1 = C2Dbl(clsBill.strGrdCell(i, xlngColPrice))
                priceTmp2 = priceTmp1 / dblFactor
                strSql = "UPDATE Item SET dblPurchasePrice = " & priceTmp2 _
                    & ",dblMaxPurchasePrice=IIF(dblMaxPurchasePrice>" & priceTmp2 & ",dblMaxPurchasePrice, " & priceTmp2 _
                    & "),dblMinPurchasePrice=IIF(dblMinPurchasePrice<" & priceTmp2 & ",dblMinPurchasePrice, " & priceTmp2 _
                    & "),dblRecenetPurchasePrice=" & priceTmp2 _
                    & " WHERE lngItemId = " & C2Lng(clsBill.strGrdCell(i, xlngColItemID))
            End Select
            gclsBase.BaseDB.Execute strSql
        End If
        '设已存储标志
        grdCol.TextMatrix(i, 0) = !lngActivityDetailID
    End With
End Sub
Private Function SaveNewBill() As Boolean
    Dim recActivity As Recordset
    Dim recDetail As Recordset
    Dim lngNewActivityID As Long
    Dim dtmDate1 As Date
    Dim strAlpha As String
    Dim lngDigit As Long
    Dim i As Long
'    On Error GoTo ErrorHandle
    Dim recTemp As Recordset
    '制单日合法性校验
    If gclsBase.PeriodClosed(lblField(2).Caption) Then
        ShowMsg 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
    gclsBase.BaseWorkSpace.BeginTrans
    '修改商品表
    Set recActivity = gclsBase.BaseDB.OpenRecordset( _
            "SELECT * FROM itemActivity where false", dbOpenDynaset)
    If recActivity Is Nothing Then
        gclsBase.BaseWorkSpace.RollBack
        GoTo EndProc
    End If
    With recActivity
        .AddNew
            lngNewActivityID = !lngActivityID
            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.RollBack
        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.OpenRecordset( _
            "SELECT * FROM ItemActivityDetail where false", _
            dbOpenDynaset)
    With recDetail
        If grdCol.Rows >= 2 Then
            For i = 1 To grdCol.Rows - 1
                If clsBill.blnNotNullRow(i) Then
                    .AddNew
                        !lngActivityID = lngNewActivityID
                        grdCol.TextMatrix(i, 0) = !lngActivityDetailID
                        SaveActivityDetailBody recDetail, i
                    .Update
                End If
            Next i
        End If
    End With
    
    gclsBase.BaseWorkSpace.CommitTrans
    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