mdlfunction.bas

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

Attribute VB_Name = "mdlFunction"
Option Explicit

'----------------------------------------------------------
'版本发展:  (自2000年9月)
'   1: 2000.9.17
'   2: 2000.9.28
'   3: 2001.2.28
'   4: 2001.5.16
'   5: 2001.5.21
'   6: 2001.5.24
'   7: 2001.9.18
'----------------------------------------------------------

'----------------------------------------------------------
'控制输入一个正整数
'控制输入一个正小数
'控制输入一个负小数
'控制输入一个数字或字母
'The contents of a delimited text file as an array of strings arrays
'write the contents of an array of string arrays to a delimited text file.
'从文本文件中读出文本内容
'写文本内容到文本文件
'检查一个将用于数据库查询的字符串是否包含某些特定字符，如"'"
'选定一个文本框中的全部文字并使其获得焦点
'根据参数生成 ADO 的数据环境连接字符串
'将一个数字形式的金额字符串转换成人民币的汉字大写形式
'----------------------------------------------------------


Public Const ITEMSPLITCHAR = "§"

'控制输入一个正整数
Public Function IntegerEnabled(ByVal KeyAsc As Integer) As Integer

    If (KeyAsc >= Asc("0") And KeyAsc <= Asc("9")) Or KeyAsc = 8 Or KeyAsc = 10 Then
        IntegerEnabled = KeyAsc
    Else
        IntegerEnabled = 0
    End If
    
End Function


'控制输入一个正小数
Public Function DoubleEnabled(ByVal sTxt As String, ByVal KeyAsc As Integer) As Integer
    
    Select Case KeyAsc
        Case 8, 10, Asc("0") To Asc("9")
            DoubleEnabled = KeyAsc
        Case Asc(".")
            If InStr(1, sTxt, ".") >= 1 Then
                DoubleEnabled = 0
            Else
                DoubleEnabled = KeyAsc
            End If
        Case Else
            DoubleEnabled = 0
    End Select
    
End Function


'控制输入一个负小数
Public Function NegativeDoubleEnabled(TB As TextBox, ByVal KeyAsc As Integer) As Integer
    Dim sTemp As String
    
    Select Case KeyAsc
        Case 8, 10, Asc("0") To Asc("9")
            If InStr(1, TB.text, "-") = 0 Then
                NegativeDoubleEnabled = KeyAsc
            Else
                sTemp = Mid(TB.text, TB.SelStart + 1)
                If InStr(1, sTemp, "-") = 0 Or TB.SelLength = Len(TB.SelText) Then
                    NegativeDoubleEnabled = KeyAsc
                Else
                    NegativeDoubleEnabled = 0
                End If
            End If
            
        Case Asc(".")
            If InStr(1, TB.text, ".") >= 1 Then
                If InStr(1, TB.SelText, ".") >= 1 Then
                    NegativeDoubleEnabled = KeyAsc
                Else
                    NegativeDoubleEnabled = 0
                End If
            Else
                sTemp = Mid(TB.text, TB.SelStart + 1)
                If InStr(1, sTemp, "-") = 0 Or TB.SelLength = Len(TB.SelText) Then
                    NegativeDoubleEnabled = KeyAsc
                Else
                    NegativeDoubleEnabled = 0
                End If
            End If
            
        Case Asc("-")
            If InStr(1, TB.text, "-") >= 1 Then
                If InStr(1, TB.SelText, "-") >= 1 Then
                    NegativeDoubleEnabled = KeyAsc
                Else
                    NegativeDoubleEnabled = 0
                End If
            ElseIf TB.SelStart <> 0 Then
                NegativeDoubleEnabled = 0
            Else
                NegativeDoubleEnabled = KeyAsc
            End If
            
        Case Else
            NegativeDoubleEnabled = 0
            
    End Select

End Function


'控制输入一个数字或字母
Public Function NumberORLetterEnabled(ByVal KeyAsc As Integer)

    Select Case KeyAsc
        Case 8, 10, Asc("0") To Asc("9")
            NumberORLetterEnabled = KeyAsc
        Case Asc("A") To Asc("Z")
            NumberORLetterEnabled = KeyAsc
        Case Asc("a") To Asc("z")
            NumberORLetterEnabled = KeyAsc
        Case Else
            NumberORLetterEnabled = 0
    End Select
            
End Function


'The contents of a delimited text file as an array of strings arrays
'NOTE: requires the ReadTextFileContents routine
Public Function ImportDelimitedFile(filename As String, _
        Optional delimiter As String = vbTab) As Variant()
    Dim lines() As String, i As Long, j As Long
    Dim values() As Variant
    
    'Get all lines in the file.
    lines() = Split(ReadTextFileContents(filename), vbCrLf)
    'To quickly delete all empty lines, load them with a special char.
    For i = 0 To UBound(lines)
        If Len(lines(i)) = 0 Then lines(i) = vbNullChar
    Next i
    'Then use the filter function to delete these lines.
    lines() = Filter(lines(), vbNullChar, False)
    'Create a string array out of each line of text
    'and store it in a Variant element.
    ReDim values(0 To UBound(lines)) As Variant
    For i = 0 To UBound(lines)
        values(i) = Split(lines(i), delimiter)
    Next i
    ImportDelimitedFile = values()
    
End Function


'write the contents of an array of string arrays to a delimited text file.
'NOTE: requires the WriteTextFileContents routine
Public Sub ExportDelimitedFile(values() As Variant, filename As String, _
        Optional delimiter As String = vbTab, Optional AppendMode As Boolean)
    Dim lines() As String
    Dim i As Long
    
    'rebulid the individual lines of text of the file.
    ReDim lines(0 To UBound(values)) As String
    For i = 0 To UBound(values)
        lines(i) = Join(values(i), delimiter)
    Next i
    'Create CRLFs among records,and write then.
    WriteTextFileContents Join(lines, vbCrLf), filename, AppendMode
    
End Sub


'从文本文件中读出文本内容
Public Function ReadTextFileContents(filename As String) As String
    Dim fnum As Integer, isOpen As Boolean
    Dim ReadTempStr
    Dim FileLength As Integer
    
    'Get the next free file number.
    On Error GoTo Error_Handler
    fnum = FreeFile()
    Open filename For Input As #fnum
    'if execution flow got here,the file has been open without error.
    isOpen = True
    'Read th entire contents in one single operation
    Do Until EOF(fnum)
        Line Input #fnum, ReadTempStr
        ReadTextFileContents = ReadTextFileContents & ReadTempStr & vbCrLf
    Loop
    
    'intentionally flow into the error handler to close the file.
Error_Handler:
    'Raise the error(if any),but first close the file.
    If isOpen Then Close #fnum
    If Err Then Err.Raise Err.Number, , Err.Description
    
End Function
'写文本内容到文本文件
Public Sub WriteTextFileContents(text As String, filename As String, _
    Optional AppendMode As Boolean)
    Dim fnum As Integer, isOpen As Boolean
    On Error GoTo Error_Handler
    'Get the next free file number;
    fnum = FreeFile()
    If AppendMode Then
        Open filename For Append As #fnum
    Else
        Open filename For Output As #fnum
    End If
    'if execution flow gets here,the file has been opened correctly.
    isOpen = True
    'Print to the file in one single operation.
    Print #fnum, text
    'intentionally flow into the error ha2ndler to close the file.
    
Error_Handler:
    'Raise the error (if any),but first close the file.
    If isOpen Then Close #fnum
    If Err Then Err.Raise Err.Number, , Err.Description
    
End Sub


'检查一个将用于数据库查询的字符串是否包含某些特定字符，如"'"
Public Function SqlStringValid(ByVal sTxt As String) As Boolean
    If sTxt = "" Then
        SqlStringValid = True
    ElseIf InStr(1, sTxt, "'") > 0 Then
        SqlStringValid = False
    ElseIf InStr(1, sTxt, "?") > 0 Then
        SqlStringValid = False
    ElseIf InStr(1, sTxt, "%") > 0 Then
        SqlStringValid = False
    Else
        SqlStringValid = True
    End If
End Function
'检查一个将用于数据库查询的字符串输入框，控制输入包含某些特定字符，如“'”
Public Function SqlStringValidText(ByVal sOldText As String, ByVal SelStart As Integer, ByVal SelLength As Integer, ByRef KeyAscii As Integer) As Boolean