frmmakeorder.frm

金算盘软件代码

    ReDim strColName(GrdCol.Cols - 1)
    ReDim xlngColNo(GrdCol.Cols - 1)
     
    For i = 0 To 5
        GrdCol.ColAlignment(i) = flexAlignLeftCenter
        strColName(i) = GrdCol.TextMatrix(0, i)
        xlngColNo(i) = i
    Next
    For i = 6 To GrdCol.Cols - 1
        GrdCol.ColAlignment(i) = flexAlignRightCenter
        strColName(i) = GrdCol.TextMatrix(0, i)
        xlngColNo(i) = i
    Next
    mclsGrid.ColOfs = 2
    mclsGrid.SetupStyle
    GrdCol.Redraw = True
    Me.MousePointer = vbDefault
End Sub

Private Sub SelectSome()
    Dim strWhere As String
    Dim strFrom As String
    Dim strSql As String
    Dim clsList As ListSet
    Dim recTmp As rdoResultset
    Dim i As Long
    Dim blnOK As Boolean
    
    Set clsList = New ListSet
    clsList.ViewId = 112
    
    If clsList.ListID = 0 Then
        clsList.SaveList
    End If
    
    strWhere = Filter.ShowFilter(clsList.ListID, 1, , , , , blnOK)
    If blnOK = False Then GoTo EndProc
    If Trim(strWhere) = "" Then
        strWhere = " Item.lngCustomerID<>0 AND Item.blnIsInActive=0 AND ItemNature.strItemCategory='1' "
    Else
        strWhere = " (" & strWhere & ") AND (Item.lngCustomerID<>0 AND Item.blnIsInActive=0 AND ItemNature.strItemCategory='1') "
    End If
    strFrom = clsList.FromOfSql
    If InStr(UCase(strFrom), "ITEMNATURE") = 0 Then
        strFrom = Mid(strFrom, InStr(UCase(strFrom), "FROM") + 4)
        strFrom = " FROM " & strFrom & ",ItemNature "
    End If
    
    strSql = "SELECT Item.lngItemID " & strFrom & " WHERE " & strWhere & " AND Item.lngItemNatureID=ItemNature.lngItemNatureID  ORDER BY Item.lngItemID"
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    With recTmp
        If .BOF And .EOF Then
            cmdokcancel_Click 5
        Else
            strSql = ""
            Do While Not .EOF
                strSql = strSql & "," & !lngItemID
                .MoveNext
            Loop
            strSql = strSql & ","
            For i = 1 To GrdCol.Rows - 1
                If InStr(strSql, "," & RowDatas(GrdCol.RowData(i)).lngItemID & ",") <> 0 Then
                    SetSelectRow i, True
                Else
                    SetSelectRow i, False
                End If
            Next
        End If
    End With
EndProc:
    Set clsList = Nothing
End Sub

Private Function DataValid() As Boolean
    Dim i As Long
    Dim strDate As String
    
    strDate = dtmInput.Text
    If strDate = "" Then
        cMsgBox "制单日期不能为空！"
        dtmInput.Text = Format(gclsBase.BaseDate, "yyyy-mm-dd")
        dtmInput.SetFocus
        Exit Function
    End If
    If Not IsDate(strDate) Then
        cMsgBox "制单日期非法！"
        dtmInput.Text = Format(gclsBase.BaseDate, "yyyy-mm-dd")
        dtmInput.SetFocus
        Exit Function
    End If
    
    With GrdCol
        For i = 1 To .Rows - 1
            If blnRowIsSelected(i) Then
                If C2Dbl(.TextMatrix(i, xlngColNo(12))) <= 0 Then
                    cMsgBox "第" & i & "行的本币含税单价必须大于0！"
                    Exit Function
                End If
                If C2Dbl(.TextMatrix(i, xlngColNo(13))) <= 0 Then
                    cMsgBox "第" & i & "行的本币含税金额必须大于0！"
                    Exit Function
                End If
                If .TextMatrix(i, xlngColNo(14)) < strDate Then
                    cMsgBox "第" & i & "行的约定到货日期不能小于制单日期！"
                    .TextMatrix(i, xlngColNo(14)) = strDate
                    Exit Function
                End If
            End If
        Next
    End With
    
    DataValid = True
End Function

Private Function blnRowIsSelected(ByVal lngRow As Long) As Boolean
    If GrdCol.TextMatrix(lngRow, 1) = "" Or C2Dbl(GrdCol.TextMatrix(lngRow, xlngColNo(11))) <= 0 Then
        blnRowIsSelected = False
    Else
        blnRowIsSelected = True
    End If
End Function

Private Function SaveBills() As Boolean
    Dim i As Long
    Dim lngID As Long
    Dim strCustomerID As String
    Dim strAlpha As String
    Dim strDigit As String
    
    With GrdCol
        For i = 1 To .Rows - 1
            If blnRowIsSelected(i) Then Exit For
        Next
        
        If i = .Rows Then
            SaveBills = True
            Exit Function
        End If
        
        If DataValid() = False Then
            Exit Function
        End If
        Me.MousePointer = vbHourglass
        BillPublic.getPrevPlateAndBillNo 1, mlngTemplateID, mstrReceiptNO
        strCustomerID = ","
        gclsBase.BaseWorkSpace.BeginTrans
        For i = 1 To .Rows - 1
            If blnRowIsSelected(i) Then
                If InStr(strCustomerID, "," & RowDatas(.RowData(i)).lngCustomerID & ",") = 0 Then
                    lngID = 0
                    strCustomerID = strCustomerID & RowDatas(.RowData(i)).lngCustomerID & ","
                    If SaveABill(lngID, i, strAlpha, strDigit) = False Then
                        gclsBase.BaseWorkSpace.RollBacktrans
                        mlngFirstID = 0
                        Exit Function
                    End If
                End If
            End If
        Next
        gclsBase.BaseWorkSpace.CommitTrans
        blnModifyMaxNO mintYear, mbytPeriod, 1, strAlpha, strDigit
        gclsSys.SendMessage 0, 31
        SaveBills = True
        Me.MousePointer = vbDefault
    End With
End Function

Private Function SaveABill(ByRef lngID As Long, ByVal lngRowno As Long, ByRef strAlpha As String, ByRef strDigit As String) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim strNo As String
    Dim i As Long
    Dim j As Long
    Dim lngPosID As Long
    Dim dblAmount As Double
    Dim dblTaxAmount As Double
    Dim dblQuantity As Double
    
    On Error GoTo ErrHandle
    strNo = strGetMaxNO(mintYear, mbytPeriod, 1, mstrReceiptNO)
    GetNewNO strNo
    strSql = "SELECT * FROM PurchaseOrder WHERE ROWNUM<1"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With recTmp
        .AddNew
        lngID = GetNewID("PurchaseOrder")
        If mlngFirstID = 0 Then mlngFirstID = lngID
        !lngPurchaseOrderID = lngID
        !blnIsPrinted = 0
        !intYear = mintYear
        !bytPeriod = mbytPeriod
        strAlpha = SubStr(BillPublic.strAlphaOfStr(LTrim(strNo)), 1, 6)
        !strReceiptNo = IIf(strAlpha = "", " ", strAlpha)           '文本,采购订单编号
        strDigit = BillPublic.strDigitOfStr(LTrim(strNo))
        !lngReceiptNo = C2lng(strDigit)       '数字,采购订单编号
        !lngClassID2 = 0                           '统计（项目）ID
        !lngClassID1 = 0                           '统计ID
        !lngTemplateID = mlngTemplateID                     '数字,模版ID
        !lngCustomerID = RowDatas(GrdCol.RowData(lngRowno)).lngCustomerID
        !lngCustomerAddressID = 0                   '单位地址ID
        !lngBusinessAddressID = 0                  '企业地址ID
        !lngDepartmentID = 0
        !lngEmployeeID = 0
        !lngTermID = 0
        !strReceiptDate = ""
        !strDueDate = ""
        !strDate = dtmInput.Text
        !lngOperatorID = gclsBase.OperatorID
        !lngCurrencyID = gclsBase.NaturalCurId
        !dblRate = 1
        !strNote = "自动生成采购订单"  '文本,备注
        !blnIsPrint = 0         '是/否,打印标志
        !blnIsVoid = 0
        !strReceiptDate = " "
        !strDueDate = " "
ReTry:
        .Update
    End With
    recTmp.Close
    Set recTmp = Nothing
    
    With GrdCol
        For i = lngRowno To .Rows - 1
            If blnRowIsSelected(i) Then
                lngPosID = .RowData(i)
                If RowDatas(lngPosID).lngCustomerID = RowDatas(.RowData(lngRowno)).lngCustomerID Then
                    j = j + 1
                    dblTaxAmount = C2Dbl(.TextMatrix(i, xlngColNo(13)))
                    dblAmount = C2Dbl(Format(dblTaxAmount / (1 + RowDatas(lngPosID).dblTaxRate), strCurrDec))
                    dblQuantity = NumberConvert(.TextMatrix(i, xlngColNo(11)), RowDatas(lngPosID).dblFactor)
                    strSql = "INSERT INTO PurchaseOrderDetail (" & _
                        "lngPurchaseOrderDetailID,lngPurchaseOrderID,lngRowID,lngItemID,lngUnitID," & _
                        "dblQuantity,dblPrice,dblPriceTax,dblDiscountRate," & _
                        "dblCurrAmount,dblAmount,lngTaxID,dblCurrTaxAmount," & _
                        "dblTaxAmount,strPromiseDate,dblReceiveQuantity,lngJobID," & _
                        "lngCustomID0,lngCustomID1,lngCustomID2,lngCustomID3," & _
                        "lngCustomID4,lngCustomID5,blnIsClose) VALUES ("
                    strSql = strSql & GetNewID("PurchaseOrderDetail") & "," & lngID & "," & j & "," & RowDatas(lngPosID).lngItemID & "," & RowDatas(lngPosID).lngUnitID & "," & _
                         dblQuantity & "," & dblAmount / dblQuantity & "," & dblTaxAmount / dblQuantity & ",100," & _
                         dblAmount & "," & dblAmount & "," & RowDatas(lngPosID).lngTaxID & "," & dblTaxAmount - dblAmount & "," & _
                         dblTaxAmount - dblAmount & ",'" & .TextMatrix(i, xlngColNo(14)) & "',0,0," & _
                         RowDatas(lngPosID).lngCustomID0 & "," & RowDatas(lngPosID).lngCustomID1 & "," & RowDatas(lngPosID).lngCustomID2 & "," & _
                         RowDatas(lngPosID).lngCustomID3 & "," & RowDatas(lngPosID).lngCustomID4 & "," & RowDatas(lngPosID).lngCustomID5 & ",0)"
                         
                    If gclsBase.ExecSQL(strSql) = False Then
                        Exit Function
                    End If
                End If
            End If
        Next
    End With
    strSql = "UPDATE Item SET Item.dblPOQuantity=(SELECT Item.dblPOQuantity+PurchaseOrderDetail.dblQuantity " & _
        " FROM PurchaseOrderDetail WHERE PurchaseOrderDetail.lngPurchaseOrderID=" & lngID & _
        " AND PurchaseOrderDetail.lngItemID=Item.lngItemID) " & _
        " WHERE EXISTS (SELECT PurchaseOrderDetail.lngItemID FROM PurchaseOrderDetail " & _
        " WHERE PurchaseOrderDetail.lngItemID=Item.lngItemID " & _
        " AND PurchaseOrderDetail.lngPurchaseOrderID=" & lngID & ")"
    If gclsBase.ExecSQL(strSql) = False Then
        Exit Function
    End If
    SaveABill = True
    Exit Function
ErrHandle:
    If InStr(Err.Description, "ORA-00001") Then
        If Not recTmp Is Nothing Then
            GetNewNO strNo
            strAlpha = SubStr(BillPublic.strAlphaOfStr(LTrim(strNo)), 1, 6)
            recTmp!strReceiptNo = IIf(strAlpha = "", " ", strAlpha)           '文本,采购订单编号
            strDigit = BillPublic.strDigitOfStr(LTrim(strNo))
            recTmp!lngReceiptNo = C2lng(strDigit)       '数字,采购订单编号
            GoTo ReTry
        End If
    End If
End Function

Private Function GetNewNO(ByRef strNo As String)
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim lngNo As Long

    If BillPublic.blnReceiptNoRepeat(dtmInput.Text, 1, strNo, 0) Then
        strNo = SubStr(BillPublic.strAlphaOfStr(LTrim(strNo)), 1, 6)
        strSql = "SELECT Max(lngReceiptNO) FROM PurchaseOrder " & _
            " WHERE ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strNo) & "'"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If recTmp.BOF And recTmp.EOF Then
            lngNo = 1
        Else
            lngNo = recTmp(0) + 1
        End If
        BillPublic.blnModifyMaxNO mintYear, mbytPeriod, 1, strNo, lngNo
        strNo = strNo & Format(lngNo, "0000")
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function
Private Sub SpinInput_Change()
    If SpinInput.Text <> "" Then
        If ContainErrorChar(SpinInput.Text, ".") Then
'            BKKEY SpinInput.hwnd    ', vbKeyBack
            SendKeys Chr(vbKeyBack)
        End If
    End If
End Sub

Private Sub SpinInput_Validate(Cancel As Boolean)
    If IsNumeric(SpinInput.Text) Then
        If C2lng(SpinInput.Text) = SpinInput.Text Then
            Exit Sub
        End If
    End If
    cMsgBox "请输入一个整数！"
    Cancel = True
End Sub