业务通用模块.bas

财务信息管理系统,适合做毕业论文的人使用

Attribute VB_Name = "mdlBudgetCommon"
Option Explicit

'常用api
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
Public Declare Function WinHelpSearch Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As String) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal lSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFilename As String) As Long

'以下函数和常量用于更换toolbar
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Const REG_SZ = 1                         ' Unicode nul terminated string
Private Const REG_BINARY = 3                     ' Free form binary
Private Const ERROR_SUCCESS = 0&
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const C_BUTTON_STYLE = "SOFTWARE\UfSoft\WF\V8.50\Appearance"
Public gToolbarStyle As Integer         '工具栏状态

'主要的作用时保存业务相关的通用方法和变量
Public m_objAid As New U8BudgetMgr.clsCommon
Public m_objAddon As New U8PAutoSetTableStruct.IAutoSet
Public m_objAuthTree As DOMDocument
Public m_objRefTree As DOMDocument
Private m_lTmpID As Long

Public Function lTmpID() As Long
    lTmpID = Int(Rnd * 1000000000)
End Function

Public Function objWrapWhere(budget As String, Optional bill As String) As DOMDocument
    Set objWrapWhere = New DOMDocument
    objWrapWhere.loadXML "<query><budget/><bill/></query>"
    objWrapWhere.documentElement.firstChild.Text = Trim(budget)
    objWrapWhere.documentElement.lastChild.Text = Trim(bill)
End Function

Public Function PrintError(doc As DOMDocument) As Boolean
    Dim Node As IXMLDOMElement

    On Error GoTo last
    PrintError = True
    Set Node = doc.documentElement.selectSingleNode("errmsg")
    If Not (Node Is Nothing) Then
        MsgBox Node.Text
    Else
        Err.Raise 1
    End If
    Set doc = Nothing
    Exit Function
last:
    Set doc = Nothing
    PrintError = False
End Function

Public Sub FillCur(obj As Object)
    Dim con As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    
    On Error GoTo last
    Set con = m_objAid.objOpenDB(g_sDataSourceName)
    Set rs = con.Execute("select i_id,cexch_name from foreigncurrency order by i_id")
    
    For i = 0 To rs.RecordCount - 1
        obj.AddItem rs(1)
        obj.ItemData(i) = CLng(rs(0))
        rs.MoveNext
    Next
    
    If obj.ListCount <> 0 Then
        obj.ListIndex = 0
    End If
    Exit Sub
last:
    Err.clear
End Sub

Public Sub SetTBStyle(myForm As Object)
    On Error Resume Next
    If gToolbarStyle = 1 Then   '文本按钮
        myForm.ocxCtbTool.Visible = False
        myForm.ocxCtbTool.SetToolbar myForm.tlbTool
        myForm.ocxCtbTool.SpecialEffect = True
        myForm.ocxCtbTool.SetDisplayStyle TextOnly
        myForm.ocxCtbTool.Visible = True
        myForm.ocxCtbTool.RefreshVisible
    Else    '图形按钮
        myForm.ocxCtbTool.SetToolbar myForm.tlbTool
        myForm.ocxCtbTool.SetDisplayStyle PictureText
        myForm.ocxCtbTool.Visible = False
    End If
    ResizeTlb myForm
End Sub

Public Function GetToolbarStyle() As ENUM_DISPLAYSTYLE
    GetToolbarStyle = TextOnly
    Dim hKey As Long
    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, C_BUTTON_STYLE, 0, KEY_QUERY_VALUE, hKey) = ERROR_SUCCESS Then ' 打开注册表键
        Dim enumStyle As ENUM_DISPLAYSTYLE
        Dim cTemp As String * 128, cStyle As String, nTemp As Long, nType As Long
        nType = REG_SZ
        nTemp = 128
        If RegQueryValueEx(hKey, "Toolbar Style", 0, nType, ByVal cTemp, nTemp) = ERROR_SUCCESS Then       ' 获得/创建键值
            If nTemp > 0 And left(cTemp, 1) = "T" Then
                GetToolbarStyle = TextOnly
            Else
                GetToolbarStyle = PictureText
            End If
        End If
        RegCloseKey (hKey)                                 ' 关闭注册表键
    End If
End Function

Public Sub SaveToolbarStyle(ByVal enumStyle As ENUM_DISPLAYSTYLE)
    Dim hKey As Long
    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, C_BUTTON_STYLE, 0, KEY_SET_VALUE, hKey) <> ERROR_SUCCESS Then ' 打开注册表键
        If RegCreateKey(HKEY_LOCAL_MACHINE, C_BUTTON_STYLE, hKey) Then
            Exit Sub
        End If
    End If
    Dim nType As Long
    Dim cTemp As String
    nType = REG_SZ
    cTemp = IIf(enumStyle = TextOnly, "T", "P")
    RegSetValueEx hKey, "Toolbar Style", 0, nType, ByVal cTemp, LenB(cTemp)           ' 获得/创建键值
    RegCloseKey (hKey)                                 ' 关闭注册表键
End Sub

Public Sub ResizeTlb(oForm As Object)
    On Error Resume Next
    If Not oForm.tlbTool.Visible Then
        oForm.ocxCtbTool.top = 0
        oForm.ocxCtbTool.left = 0
        oForm.ocxCtbTool.width = oForm.width
    End If
End Sub

'Public Sub ShowGhMsg(MsgStr As String)
'    On Error Resume Next
'    Screen.MousePointer = vbHourglass
'    frmGhLogo.lblMsg = MsgStr
'
'    frmMain.Enabled = False
'    DoEvents
'    frmGhLogo.Show
'    frmGhLogo.AnimationPlay.Play
'    DoEvents
'End Sub

'Public Sub UnShowGhMsg()
'    On Error Resume Next
'    Screen.MousePointer = vbDefault
'    frmGhLogo.AnimationPlay.Stop
'    frmMain.Enabled = True
'    DoEvents
'    Unload frmGhLogo
'End Sub

Public Function LittleToBig(strNum As String) As String
     '这个函数将人民币小写转换为大写形式。
     '函数要求传过来的字符串必须是具有两位小数的格式。
     
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim strmid As String
    Dim strTemp As String
    Dim myarray(10) As String
    myarray(0) = "零"
    myarray(1) = "壹"
    myarray(2) = "贰"
    myarray(3) = "叁"
    myarray(4) = "肆"
    myarray(5) = "伍"
    myarray(6) = "陆"
    myarray(7) = "柒"
    myarray(8) = "捌"
    myarray(9) = "玖"
    
    strNum = Trim(strNum)
    If Len(strNum) < 4 Or Len(strNum) > 14 Then
        LittleToBig = ""
        MsgBox "数字位数不符合要求，请重试！", vbOKOnly, "转换大写提示"
        Exit Function
    End If
    
    If Not IsNumeric(strNum) Then
        LittleToBig = ""
        MsgBox "包含非数字字符！", vbOKOnly, "转换大写提示"
        Exit Function
    End If
    
    If val(strNum) < 0 Then
        LittleToBig = 0
        Exit Function
    End If
    
    
    For i = 1 To Len(strNum)    '去掉前面的0（如果有的话）
        If left(strNum, 1) = "0" Then
            strNum = right(strNum, Len(strNum) - 1)
        End If
    Next i
    i = Len(strNum) - 3   '小数点前的位数
    
    
    
    For j = i To 1 Step -1
        Select Case j
            Case 1
                strTemp = "元"
            Case 2, 6, 10
                strTemp = "拾"
            Case 3, 7, 11
                strTemp = "佰"
            Case 4, 8
                strTemp = "仟"
            Case 5
                strTemp = "万"
            Case 9
                strTemp = "亿"
        End Select
        k = CInt(mID(strNum, i - j + 1, 1)) '从左往右数第j位数是k
        If k = 0 Then
            If j = 1 Or j = 5 Or j = 9 Then '个位或者是万位或者亿位
                If right(strmid, 1) = myarray(k) Then   '如果前面一个字符是零，去掉，加（元，万）
                    strmid = left(strmid, Len(strmid) - 1) & strTemp
                Else
                    strmid = strmid & strTemp   '直接加（元，万），不说零元零万
                End If
            Else
                If right(strmid, 1) <> myarray(k) Then
                    strmid = strmid & myarray(k)    '只加零，不加单位（十，百，千）
                End If
            End If
        Else
            strmid = strmid & myarray(k) & strTemp
        End If
    Next j
    
    k = CInt(mID(strNum, Len(strNum) - 1, 1))
    i = CInt(right(strNum, 1))
    If k = 0 And i = 0 Then
        If strmid <> "" Then strmid = strmid & "整"
    Else
        If i = 0 Then
            strmid = strmid & myarray(k) & "角"
        ElseIf k = 0 Then
                strmid = strmid & myarray(k) & myarray(i) & "分"
        Else
            strmid = strmid & myarray(k) & "角" & myarray(i) & "分"
        End If
    End If
    LittleToBig = strmid

End Function

Public Function GetRearpart(strAll As String) As String
    Dim iPos As Integer
    
    iPos = InStr(1, strAll, ":")
    If iPos <> 0 Then
        GetRearpart = mID(strAll, iPos + 1)
    End If
End Function
'Public Function GetErrStr(ErrCode As Long) As String
'Dim ErrStr As String
'
'Select Case ErrCode
'    Case 1
'        ErrStr = "数据或者格式没有初始化"
'    Case 2
'        ErrStr = "系统没有安装打印机"
'    Case 3
'        ErrStr = "取系统缺省打印机时发生异常"
'
'    'SetDataStyleXml
'    Case 1001
'        ErrStr = "一般性初始化错误"
'    Case 1002
'        ErrStr = "XML文档错误"
'    Case 1003
'        ErrStr = "非法ID参数"
'    Case 1097
'        ErrStr = "一般性数据错误"
'    Case 1098
'        ErrStr = "一般性格式错误"
'    Case 1099
'        ErrStr = "一般性错误"
'    Case 1101
'        ErrStr = "没有数据"
'    Case 1102
'        ErrStr = "数据为空"
'    Case 1103
'        ErrStr = "非法数据"
'    Case 1104
'        ErrStr = "读取数据文件时发生错误"
'    Case 1105
'        ErrStr = "读取数据串时发生错误"
'    Case 1201
'        ErrStr = "没有格式"
'    Case 1202
'        ErrStr = "格式为空"
'    Case 1203
'        ErrStr = "格式非法"
'    Case 1204
'        ErrStr = "读取格式文件时发生错误"
'    Case 1205
'        ErrStr = "读取格式串时发生错误"
'    Case 1206
'        ErrStr = "需要纸张尺寸"
'    Case 1301
'        ErrStr = "没有模板编号"
'
'    'PrintPreview
'    Case 2001
'        ErrStr = "没有足够的格式信息"
'
'    'ExportToFile
'    Case 3000
'        ErrStr = "未知异常"
'    Case 3001
'        ErrStr = "字段类型和大小未提供"
'    Case 3002
'        ErrStr = "没有提供数据表格"
'    Case 3003
'        ErrStr = "没有找到系统格式数据库"
'    Case 3004
'        ErrStr = "数据表没有表头，无法确定字段名"
'    Case 3005
'        ErrStr = "数据表格列数少于指定的字段类型数目"
'    Case 3006
'        ErrStr = "输出失败"
'    Case 3007
'        ErrStr = "创建临时表失败"
'    Case 3008
'        ErrStr = "删除临时表失败"
'    Case 3009
'        ErrStr = "数据库没有连接"
'    Case 3010
'        ErrStr = "无法打开注册表"
'    Case 3011
'        ErrStr = "临时表尚未创建"
'    Case 3012
'        ErrStr = "没有ISAM项目"
'    Case 3013
'        ErrStr = "没有数据"
'    Case 3014
'        ErrStr = "JobId溢出"
'    Case 3015
'        ErrStr = "向临时表插入数据失败"
'
'    'GetPaperSize
'    Case 10101
'        ErrStr = "无法识别的纸张类型或者所选打印机不支持"
'    Case 10102
'        ErrStr = "无效的打印机名"
'
'    'CoutPageMargin
'    Case 10201
'        ErrStr = "页边距过小"
'
'    'ComputePageInfo
'    Case 10301
'        ErrStr = "设置的行高过大"
'
'    'DrawMultiLayerTableHeader
'    Case 10401
'        ErrStr = "列索引溢出"
'
'    '其他
'    Case 3999   '输出到文件时用户选择取消
'        ErrStr = "用户选择取消"
'
'    Case Else
'        ErrStr = "未知错误"
'
'End Select
'
'GetErrStr = ErrStr