modpub.bas

完成报销系统的业务流程；在报销系统中达到预算控制目的；将历史数据导入金蝶账套生成历史备查数据。

Attribute VB_Name = "modPub"
Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

Public Const HINTINFO = "金蝶提示"
Public lBudgetProjectID As Long '当前预算方案编号
Public LOGFILE As String
Dim CHAp(21, 1)
'初始化:
Function init()
    CHAp(0, 0) = "万": CHAp(0, 1) = 10000
    CHAp(1, 0) = "仟": CHAp(1, 1) = 1000
    CHAp(2, 0) = "佰": CHAp(2, 1) = 100
    CHAp(3, 0) = "拾": CHAp(3, 1) = 10
    CHAp(4, 0) = "元": CHAp(4, 1) = 1
    CHAp(5, 0) = "角": CHAp(5, 1) = 0.1
    CHAp(6, 0) = "分": CHAp(6, 1) = 0.01
    CHAp(11, 0) = "壹": CHAp(11, 1) = 1
    CHAp(12, 0) = "贰": CHAp(12, 1) = 2
    CHAp(13, 0) = "叁": CHAp(13, 1) = 3
    CHAp(14, 0) = "肆": CHAp(14, 1) = 4
    CHAp(15, 0) = "伍": CHAp(15, 1) = 5
    CHAp(16, 0) = "陆": CHAp(16, 1) = 6
    CHAp(17, 0) = "柒": CHAp(17, 1) = 7
    CHAp(18, 0) = "捌": CHAp(18, 1) = 8
    CHAp(19, 0) = "玖": CHAp(19, 1) = 9
    CHAp(20, 0) = "零": CHAp(20, 1) = 0
    CHAp(21, 0) = "亿": CHAp(21, 1) = 100000000
End Function


Function SubtoChinese(price As Integer)
'转化千百十
Dim i As Integer
Dim num(15) As Integer
i = 1
    Do Until price = 0
        num(i) = Int(price / CHAp(i, 1))
        If num(i) <> 0 Then
            SubtoChinese = SubtoChinese & CHAp(num(i) + 10, 0) & CHAp(i, 0)
            price = price - num(i) * CHAp(i, 1)
        Else
            If SubtoChinese <> "" And Right(SubtoChinese, 1) <> "零" Then
                SubtoChinese = SubtoChinese & "零"
            End If
        End If
        i = i + 1
    Loop
    If Right(SubtoChinese, 1) = "元" Then
        SubtoChinese = Left(SubtoChinese, Len(SubtoChinese) - 1)
    End If
End Function

Function PricetoChinese(price As Currency) As String

    init
    If price = 0 Then
        PricetoChinese = ""
        Exit Function
    End If
    If price >= 100000000 Then   '大于1亿
        PricetoChinese = PricetoChinese & PricetoChinese(Int(price / 100000000))
        PricetoChinese = Left(PricetoChinese, Len(PricetoChinese) - 2) & "亿"
        price = price - Int(price / 100000000) * 100000000
    End If
    If price >= 10000 Then
        PricetoChinese = PricetoChinese & SubtoChinese(Int(price / 10000)) & "万"
        price = price - Int(price / 10000) * 10000
    End If
    If Int(price) <> 0 Then '如果万与千间无数，则应添零
        If PricetoChinese <> "" And Int(price) < 1000 Then
            PricetoChinese = PricetoChinese & "零"
        End If
        PricetoChinese = PricetoChinese & SubtoChinese(Int(price))
        price = price - Int(price)
    End If
    If PricetoChinese <> "" Then PricetoChinese = PricetoChinese & "元"
    If price = 0 Then '到元为止
        PricetoChinese = PricetoChinese & "整"
    Else
        price = Int(price * 100)
        If Int(price / 10) <> 0 Then
            PricetoChinese = PricetoChinese & CHAp(Int(price / 10) + 10, 0) & "角"
            price = price - Int(price / 10) * 10
         End If
         If price <> 0 Then
            PricetoChinese = PricetoChinese & CHAp(Int(price) + 10, 0) & "分"
            
         End If
    End If
    
End Function


Public Sub ImportLog12(ByVal strConten As String)
    LOGFILE = App.Path & "\" & "lxd.log"
    Dim mFileNumber As Long
    mFileNumber = FreeFile()
    Open LOGFILE For Append As #mFileNumber
    Print #mFileNumber, strConten
    Close #mFileNumber
End Sub
'根据年份期间取一月的最后一天
Public Function getDate(sYear As String, sPeriod As String) As Date
    Dim tmpDate As String
    Dim dDate As Date
    tmpDate = sYear & "-" & sPeriod & "-01"
    If IsDate(tmpDate) Then dDate = CDate(tmpDate)
    dDate = DateAdd("m", 1, dDate)
    getDate = DateAdd("d", -1, dDate)
    
End Function

Public Function GetConnectionProperty(strName As String, Optional ByVal bRaiseError As Boolean = True) As Variant
    
    Dim spmMgr As Object
    
    Dim lProc As Long
    lProc = GetCurrentProcessId()
    Set spmMgr = CreateObject("PropsMgr.ShareProps")
    If IsObject(spmMgr.GetProperty(lProc, strName)) Then
        Set GetConnectionProperty = spmMgr.GetProperty(lProc, strName)
    Else
        GetConnectionProperty = spmMgr.GetProperty(lProc, strName)
    End If
End Function