mdlfunction.bas

一个用VB写的财务软件源码

Dim s As String
If Len(sOldText) > 0 Then
    If SelStart > 0 Then
        s = Left$(sOldText, SelStart)
    End If
    If SelLength > 0 Then
        s = s + chr((KeyAscii + 65535) Mod 65535) + Mid$(sOldText, SelStart + SelLength)
    Else
        If SelStart + SelLength < Len(sOldText) Then
            s = s + chr((KeyAscii + 65535) Mod 65535) + Mid$(sOldText, SelStart + SelLength + 1)
        Else
            s = s + chr((KeyAscii + 65535) Mod 65535)
        End If
    End If
Else
    s = chr((KeyAscii + 65535) Mod 65535)
End If
If SqlStringValid(s) = True Then
    SqlStringValidText = True
Else
    SqlStringValidText = False
    KeyAscii = 0
End If
End Function

'选定一个文本框中的全部文字并使其获得焦点
Public Sub FullSelTextbox(ByRef TB As TextBox)
    TB.SelStart = 0
    TB.SelLength = Len(TB.text)
    TB.SetFocus
End Sub


'根据参数生成 ADO 的数据环境连接字符串
'   Server      Server name/Database alias
'   User        the user having administrator authorities
'   Password    the password of the user above
'   [Database]  the database to connect, be effective on SQL Server 7.0 only,
'               but it can also be used by Access to point a MDB file's path
Public Function GetConnectString(ByVal Flat As String, ByVal Server As String, _
        ByVal User As String, ByVal Password As String, _
        Optional ByVal Database As String = "") As String
    Select Case Flat
'        Case "SQL"
'            GetConnectString = "Provider=MSDASQL.1;" & _
'                "Persist Security Info=False;User ID=" & _
'                User & ";Extended Properties=" & Chr(34) & _
'                "DRIVER=SQL Server;SERVER=" & Server & _
'                ";Pwd=" & Password & ";WSID=;DATABASE=" & _
'                Database & Chr(34)
        Case "SQL"
            GetConnectString = "Provider=SQLOLEDB.1;" & _
                "Persist Security Info=False;User ID=" & _
                User & ";" & _
                "Initial Catalog=" + Database + "" & _
                ";Pwd=" & Password & ";Data Source=" & _
                Server
        Case "ORACLE"
            GetConnectString = "Provider=MSDAORA.1;User ID=" & _
                User & ";Password=" & Password & _
                ";Data Source=" & Server & _
                ";Persist Security Info=false"
        Case Else
            Err.Raise 5
    End Select
End Function


'将一个数字形式的金额字符串转换成人民币的汉字大写形式
Public Function Dxrmb(ByVal abc As String) As String
    Dim Buff(13, 2) As String
    Dim tmp As String, Rmb As String
    Dim i As Long, j As Long, k As Long
    
    Buff(13, 1) = "0"
    Buff(13, 2) = "佰"
    Buff(12, 1) = "0"
    Buff(12, 2) = "拾"
    Buff(11, 1) = "0"
    Buff(11, 2) = "亿"
    Buff(10, 1) = "0"
    Buff(10, 2) = "仟"
    Buff(9, 1) = "0"
    Buff(9, 2) = "佰"
    Buff(8, 1) = "0"
    Buff(8, 2) = "拾"
    Buff(7, 1) = "0"
    Buff(7, 2) = "万"
    Buff(6, 1) = "0"
    Buff(6, 2) = "仟"
    Buff(5, 1) = "0"
    Buff(5, 2) = "佰"
    Buff(4, 1) = "0"
    Buff(4, 2) = "拾"
    Buff(3, 1) = "0"
    Buff(3, 2) = "元"
    Buff(2, 1) = "0"
    Buff(2, 2) = "角"
    Buff(1, 1) = "0"
    Buff(1, 2) = "分"

    tmp = ""
    k = Len(Trim$("" & abc))
    j = k - 1
    If j > 13 Then Exit Function
    
    For i = 1 To k
        If Mid$(abc, i, 1) <> "." Then
           Buff(j, 1) = Trim$("" & Dxhz(Mid$(abc, i, 1)))
           j = j - 1
        End If
    Next i
    
    Rmb = ""
    k = k - 1
    For i = k To 1 Step -1
        If i = 11 Or i = 7 Or i = 3 Then
            If Trim$("" & Buff(i, 1)) = "零" Then
                If i = 7 And Trim$("" & Buff(i + 1, 1)) = "零" _
                      And Trim$("" & Buff(i + 2, 1)) = "零" _
                      And Trim$("" & Buff(i + 3, 1)) = "零" Then
                    'NOP
                Else
                    Rmb = Trim$("" & Rmb) & Trim$("" & Buff(i, 2))
                End If
                tmp = "零"
            Else
                Rmb = Trim$("" & Rmb) & Trim$("" & tmp) & Trim$("" & Buff(i, 1)) & Trim$("" & Buff(i, 2))
                tmp = ""
            End If
        Else
            If Trim$("" & Buff(i, 1)) = "零" Then
                tmp = "零"
            Else
                Rmb = Trim$("" & Rmb) & Trim$("" & tmp) & Trim$("" & Buff(i, 1)) & Trim$("" & Buff(i, 2))
                tmp = ""
            End If
        End If
    Next i

    If Trim$("" & Buff(1, 1)) = "零" Then Rmb = Trim$("" & Rmb) & "整"
    If Trim$("" & Rmb) = "整" Then Rmb = ""
    Dxrmb = Trim$("" & Rmb)
    
End Function
'小写转大写
Private Function Dxhz(ByVal abc As String) As String
    Dim s1 As String
    
    Select Case Trim$("" & abc)
        Case "0"
            s1 = "零"
        Case "1"
            s1 = "壹"
        Case "2"
            s1 = "贰"
        Case "3"
            s1 = "叁"
        Case "4"
            s1 = "肆"
        Case "5"
            s1 = "伍"
        Case "6"
            s1 = "陆"
        Case "7"
            s1 = "柒"
        Case "8"
            s1 = "捌"
        Case "9"
            s1 = "玖"
    End Select
    Dxhz = s1
    
End Function


'This module contains all the declarations to use the
'Windows 95 Shell API to use the browse for folders
'dialog box.  To use the browse for folders dialog box,
'please call the BrowseForFolders function using the
'syntax: stringFolderPath=BrowseForFolders(Hwnd,TitleOfDialog)
Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
     
    'declare variables to be used
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

    '初始化变量
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With

    'Call the browse for folder API
     lpIDList = SHBrowseForFolder(udtBI)
     
    'get the resulting string path
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If

    'If cancel was pressed, sPath = ""
     BrowseForFolder = sPath

End Function

'根据个人信息获取部门代码
Public Function GetDepartmentCodeWithPerson(ByVal sPerson As String) As String
Dim rSt As New Recordset
rSt.Open "Select bmbh from " + GetPersTableName() + " where zgbh='" + Trim$(sPerson) + "'", glo.cnnMain, adOpenKeyset, adLockPessimistic
If rSt.EOF = False Then
    GetDepartmentCodeWithPerson = FormatToString(rSt.Fields(0).Value)
End If
rSt.Close
End Function

'强制转换成字符串
Public Function FormatToString(s As Variant) As String
If IsNull(s) Then
    FormatToString = ""
Else
    FormatToString = CStr(s)
End If
End Function

'强制转换数值
Public Function FormatToDouble(d As Variant) As Double
If IsNull(d) Then
    FormatToDouble = 0
ElseIf IsNumeric(d) Then
    FormatToDouble = CDbl(d)
Else
    FormatToDouble = Val(CStr(d))
End If
End Function