balance.bas

金算盘软件代码

Attribute VB_Name = "Balance"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'标题：数量检测、转换与显示模块
'作者：邓普德
'日期：1998.07.23
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Public Const DlListFormLeft = 100               '窗体左边空距
Public Const DlListFormRight = 100              '窗体右边空距
Public Const DlListUpAreaHeight = 500           '窗体顶边空距
Public Const DlListDownAreaHeight = 500         '窗体底边空距
Public Const DlListFormBottom = 100             '窗体底边空距
Public Const DlListFormTop = 100                '窗体顶边空距
Public Const DlFormButtonWidth = 1215           '窗体按钮宽
Public Const DlFormButtonHeight = 350           '窗体按钮高
Public Function check_modisl(strSource As String, dblInVoice As Double, dbltran As Double) As String    '将最小计量单位数量转换为显示数量
'strSource：待检测的数量串（实际计量单位值）
'dblInvoice：可供结算的数量（最小计量单位值）
'dbltran：实际计量单位与最小计量单位间的换算因子值
Dim str As String, stp As String, p As Double, k As Double, l As Integer
    If IsNull(strSource) = False And Len(Trim(strSource)) > 0 Then
       str = Trim(CStr(Val(strSource)))
       l = InStr(1, str, ".")
       If l > 0 Then
          p = CDbl(Right(str, Len(str) - l))
       Else
          p = 0
       End If
       stp = Balance.intTodec(CDbl(str), dbltran, False)
       If l > 0 Then
            l = InStr(1, stp, ".")
            If l > 0 Then
               k = CDbl(Right(stp, Len(stp) - l))
            Else
               k = 0
            End If
            If (Abs(CDbl(translate_minsl(str, dbltran))) > Abs(dblInVoice)) Or (Len(Right(str, Len(str) - l)) > Len(CStr(dbltran))) Or p >= dbltran Or k >= dbltran Then
                 check_modisl = "A"
            Else
                 check_modisl = stp
            End If
       Else
            If (Abs(CDbl(str)) > Abs(dblInVoice)) Then
                 check_modisl = "A"
            Else
                 check_modisl = stp
            End If
       End If
    Else
       check_modisl = ""
    End If
End Function
Public Function translate_minsl(strSource As String, dbltran As Double) As String
'strSource：待检测的数量串（实际计量单位值）
'dbltran：实际计量单位与最小计量单位间的换算因子值
'功能:将当前单位数量转换为最小计量单位数量
Dim str As String, p As Integer, k As Double
    If IsNull(strSource) = False And Len(Trim(strSource)) > 0 Then
       str = Trim(CStr(Val(strSource)))
       p = InStr(1, str, ".")
       If p > 0 Then          '         '将当前单位数量转换为最小计量单位数量
          If p > 1 Then
             k = CDbl(Left(str, p - 1)) * dbltran + IIf(CDbl(str) < 0, (-1) * CDbl(Right(str, Len(str) - p)), CDbl(Right(str, Len(str) - p)))
          Else
             k = IIf(CDbl(str) < 0, (-1) * CDbl(Right(str, Len(str) - p)), CDbl(Right(str, Len(str) - p)))
          End If
       Else
          k = CDbl(str) * dbltran
       End If
       str = CStr(k)
       translate_minsl = str
    Else
       translate_minsl = "0"
    End If
End Function

Public Function translate_showsl(strSource As String, strUnit As String, strmin As String, dbltran As Double) As String     '将最小计量单位数量转换为显示数量
Dim p As Integer
    If IsNull(strSource) = False Then
       p = CDbl(strSource)
'       translate_showsl = CStr(p \ dbltran) & strunit & IIf((p Mod dbltran) = 0, "", CStr((p Mod getnumber(.Row, 16))) & strmin)          '将最小计量单位数量转换为当前单位数量
    Else
       translate_showsl = ""
    End If
End Function

Public Function check_modidl(strSource As String, dblInVoice As Double, dbltran As Double) As String    '将最小计量单位数量转换为显示数量
'strSource：待检测的数量串（实际计量单位值）
'dblInvoice：可供结算的数量（实际计量单位值）
'dbltran：实际计量单位与最小计量单位间的换算因子值
Dim str As String, stp As String, p As Double, k As Double, l As Integer
    If IsNull(strSource) = False And Len(Trim(strSource)) > 0 Then
       str = Trim(CStr(Val(strSource)))
       l = InStr(1, str, ".")
       If l > 0 And Len(str) <> l Then
          p = CDbl(Right(str, Len(str) - l))
       Else
          p = 0
       End If
       stp = Balance.intTodec(CDbl(str), dbltran, False)
       If l > 0 Then
            l = InStr(1, stp, ".")
            If l > 0 Then
               k = CDbl(Right(stp, Len(stp) - l))
            Else
               k = 0
            End If
            If (Abs(CDbl(str)) > Abs(dblInVoice)) Or (Len(Right(str, Len(str) - l)) > Len(CStr(dbltran))) Or p >= dbltran Or k >= dbltran Then
                 check_modidl = "A"
            Else
                 check_modidl = stp
            End If
       Else
            If (Abs(CDbl(str)) > Abs(dblInVoice)) Then
                 check_modidl = "A"
            Else
                 check_modidl = stp
            End If
       End If
    Else
       check_modidl = ""
    End If
End Function
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function intTodec(ByVal dblNumber As Double, ByVal dblMinFactor As Double, ByVal blnint As Boolean) As String
'dblNumber     ： 转换数量
'dblMinFactor  ： 换算因子
'blnint:       ： 功能选择；blnint=True，则将最小计量单位转换为库存实际单位。blnint=False，则进行数量的合法性转换
    Dim intLen As Integer
    Dim dblDec As Double
    Dim intlenDec As Integer
    Dim intlenFactor As Integer
    Dim strDec As String
    Dim dblInt As Double
    If blnint = True Then
        intTodec = Trim(str(Int(dblNumber / dblMinFactor))) + IIf(dblMinFactor = 1, "", ".") + String(Len(Trim(str(dblMinFactor))) - Len(Trim(str(dblNumber Mod dblMinFactor))), "0") + IIf(dblMinFactor = 1, "", Trim(str(dblNumber Mod dblMinFactor)))
'        dblInt = Abs(dblNumber / dblMinFactor)
 '       intTodec = Trim(str(Int(dblInt))) + IIf(dblMinFactor = 1, "", ".") + String(Len(Trim(str(dblMinFactor))) - Len(Trim(str(Int((dblInt - Int(dblInt)) * dblMinFactor)))), "0") + IIf(dblMinFactor = 1, "", Trim(str(Int((dblInt - Int(dblInt)) * dblMinFactor))))
        If dblNumber < 0 Then
           intTodec = intTodec * (-1)
        End If
    Else
       If dblMinFactor <> 1 Then
        '计量因子长度
        intlenFactor = Len(Trim(str(dblMinFactor)))
        '求整数
        dblInt = IIf(dblNumber < 0, 0, Int(dblNumber))
        '求小数
        dblDec = IIf(dblNumber - Int(dblNumber) > 0, Val("0." + Right(Trim(str(dblNumber)), Len(Trim(str(dblNumber))) - InStr(Trim(str(dblNumber)), "."))), 0)
        '求小数长度(包括小数点)
        intlenDec = IIf(dblDec = 0, 1, Len(Trim(str(dblDec))))
        '求长度
        intLen = intlenFactor - intlenDec + 1
        intLen = IIf(intLen < 0, 0, intLen)
        '求小数字符串
        strDec = Right(Trim(str(dblDec)), Len(Trim(str(dblDec))) - 1)
        strDec = IIf(Len(strDec) > intlenFactor, Left(strDec, intlenFactor), strDec)
        intTodec = Trim(str(dblInt)) + IIf(dblMinFactor > 0, ".", "") + strDec + String(intLen, "0")
'        dblInt = IIf(intLen < 0, Left(Trim(str(dblNumber)), Len(Trim(str(dblNumber))) - 1), Trim(str(dblNumber)))
'        intTodec = IIf(dblNumber - Int(dblNumber) = 0, ".", "") + String(IIf(intLen < 0, 0, intLen), "0")
      Else
         intTodec = dblNumber
      End If
    End If
End Function
Public Function FindClosedCol(ByRef objGrid As Object) As Integer
'objGrid   ： Grid名称
'功能      ： 查找关闭列
    Dim i As Integer
    i = 5
    With objGrid
    Do While i < .Cols
        If .TextMatrix(0, i) = "关闭" Then
            FindClosedCol = i
            Exit Do
        End If
        i = i + 1
    Loop
    End With
End Function
'判断是否显示勾
Public Function CheckColsedCol(ByRef objGrid As Object, ByVal intFromCol As Integer, ByVal intCloseCol As Integer) As Integer
    Dim i As Integer
    i = intFromCol
    CheckColsedCol = 420
    Do While i < intCloseCol + 1
        CheckColsedCol = CheckColsedCol + objGrid.ColWidth(i)
        i = i + 1
    Loop
End Function
'写销售单与采购单的Grid
Public Sub WriteSaleOrPurchaseGrid(ByRef FromGrid As Object, ByRef ToGrid As Object, _
     ByVal blnSale As Boolean, ByVal intCurrAmountCol As Integer, _
     ByVal dblAdd As Double, ByVal intNumberCol As Integer, ByRef ToFormName As Object)
'FromGrid   ： 来源对话框Grid
'ToGrid     ： 对方单据Grid
'blnSale    ： 业务是销售否
'intCurrAmountCol ： 金额所在列位置
'dblAdd     ： 增值率
'intNumberCol：数量列位置
'ToFormName ： 对方单据窗体名称
    Dim lngActivityDetailID As Long
    Dim lngItemID As Long
    Dim i As Integer
    Dim strSql As String
    Dim strSelect As String
    Dim strFrom As String
    Dim recRecordset As rdoResultset
    Dim dblAmount As Double
    Dim dblPrice As Double
    Dim dblCurrAmount As Double
    Dim dblCurrPrice As Double
    Dim dblNumber As Double
    Dim dblhl As Double
    Dim intRow2 As Integer    '单据行
    Dim j As Integer
    '选取写对方Grid的字段
    strSelect = "SELECT ItemActivityDetail.lngItemID AS G28, ItemActivityDetail.lngUnitID AS G31," _
        & "ItemActivityDetail.lngPositionID AS G30, ItemActivityDetail.lngTaxID AS G32," _
        & "ItemActivityDetail.lngJobID AS G33, ItemActivityDetail.lngCustomID0 AS G34,Position.strPositionName As G3," _
        & "ItemActivityDetail.lngCustomID1 AS G35,ItemActivityDetail.lngCustomID2 AS G36," _
        & "ItemActivityDetail.lngCustomID3 AS G37, ItemActivityDetail.lngCustomID4 AS G38," _
        & "ItemActivityDetail.lngCustomID5 AS G39, Trim(Item.strItemCode)+Trim(Item.strItemName" _
        & ")+Trim(Item.strItemStyle) AS G1, Custom1.strCustomName AS G22, Custom2.strCustomName " _
        & "AS G23, Custom0.strCustomName AS G24, Custom5.strCustomName AS G25, Custom4.strCustomName" _
        & " AS G26, Custom3.strCustomName AS G27, JOb.strJobName AS G21, ItemUnit.dblFactor AS G40, ItemUnit.strUnitName AS G4," _
        & "PurchaseOrder.strReceiptNO & ' ' AS G2,Format(PurchaseOrder.lngReceiptNO, '0000') AS G82, PurchaseOrder.lngPurchaseOrderID" _
        & " AS G29, Tax.dblPurchaseTaxRate AS G111, Tax.dblSaleTaxRate AS G112," _
        & "ItemActivityDetail.dblCurrAmount+ItemActivityDetail.dblCurrTaxAmount AS G12," _
        & "ItemActivityDetail.dblAmount+ItemActivityDetail.dblTaxAmount AS G15," _
        & "ItemActivityDetail.dblTaxAmount AS G13, ItemActivityDetail.dblCurrTaxAmount AS G14," _
        & "ItemActivityDetail.dblExpenseAmount AS G16, ItemActivityDetail.strProduceNum AS G17," _
        & "ItemActivityDetail.strProduceDate AS G18, ItemActivityDetail.strValidDate AS G19," _
        & "ItemActivityDetail.intValidDay AS G20,Rate.dblRate, ItemActivityDetail.dblCurrPrice AS G6"
'备份    strSelect = "SELECT ItemActivityDetail.lngItemID AS G28, ItemActivityDetail.lngUnitID AS G31," _
        & "ItemActivityDetail.lngPositionID AS G30, ItemActivityDetail.lngTaxID AS G32," _
        & "ItemActivityDetail.lngJobID AS G33, ItemActivityDetail.lngCustomID0 AS G34,Position.strPositionName As G3," _
        & "ItemActivityDetail.lngCustomID1 AS G35,ItemActivityDetail.lngCustomID2 AS G36," _
        & "ItemActivityDetail.lngCustomID3 AS G37, ItemActivityDetail.lngCustomID4 AS G38," _
        & "ItemActivityDetail.lngCustomID5 AS G39, Trim(Item.strItemCode)+Trim(Item.strItemName" _
        & ")+Trim(Item.strItemStyle) AS G1, Custom1.strCustomName AS G22, Custom2.strCustomName " _
        & "AS G23, Custom0.strCustomName AS G24, Custom5.strCustomName AS G25, Custom4.strCustomName" _
        & " AS G26, Custom3.strCustomName AS G27, JOb.strJobName AS G21, ItemUnit.dblFactor AS G40, ItemUnit.strUnitName AS G4," _
        & "PurchaseOrder.strReceiptNO & ' ' AS G2,Format(PurchaseOrder.lngReceiptNO, '0000') AS G82, PurchaseOrder.lngPurchaseOrderID" _
        & " AS G29, Tax.dblPurchaseTaxRate AS G111, Tax.dblSaleTaxRate AS G112," _
        & "ItemActivityDetail.dblCurrAmount+ItemActivityDetail.dblCurrTaxAmount AS G12," _
        & "ItemActivityDetail.dblAmount+ItemActivityDetail.dblTaxAmount AS G15," _
        & "ItemActivityDetail.dblTaxAmount AS G13, ItemActivityDetail.dblCurrTaxAmount AS G14," _
        & "ItemActivityDetail.dblExpenseAmount AS G16, ItemActivityDetail.strProduceNum AS G17," _
        & "ItemActivityDetail.strProduceDate AS G18, ItemActivityDetail.strValidDate AS G19," _
        & "ItemActivityDetail.intValidDay AS G20,Rate.dblRate, ItemActivityDetail.dblCurrPrice AS G6"