系统_基本函数模块.bas

适合于中小型企业管理

Attribute VB_Name = "XtjbModule"
'系统基本模块(主要用来放置公用函数及模块)
                
'系统信息
Public XtMenuList As String    '系统菜单功能编码

'系统日期
Public Xtkjqjgs As Integer     '用户设定会计期间个数
Public Xtyear As Integer       '用户进入系统选择年度
Public Xtmm As Integer         '用户进入系统选择会计期间
Public Xtrq As Date            '系统日期
Public Xtrlbz As String        '系统日历标志

'系统往返参数值
Public Xtcdcs As String        '系统传递参数值(专门用来传递帮助信息)
Public Xtcdcsfz As String      '系统传递参数值(辅助信息)
Public Xtfhcs As String        '系统返回参数值(专门用来传递帮助信息)
Public Xtfhcsfz As String      '系统返回参数值(辅助信息)

'系统通用编码参照代码
Public Xtbmczdm As String      '系统通用编码参照代码

'(系统等待调用窗体)
Public XtCxgnsm As String      '调用程序功能说明

Public Xtczy As String         '系统使用操作员
Public Xtczybm As String       '系统操作员编码
Public Xtztbm As String        '系统帐套编码
Public Xtdwm As String         '系统打开帐套单位

'帐套基本参数
Public Xtjezws As Integer      '金额总位数
Public Xtslzws As Integer      '数量总位数
Public Xtdjzws As Integer      '单价总位数
Public Xtjexsws As Integer     '金额小数位数
Public Xtslxsws As Integer     '数量小数位数
Public Xtdjxsws As Integer     '单价小数位数
Public XtSCurrCode As String   '本位币编码
Public XtSCurrName As String   '本位币名称

'其它全局变量
Public Unload_TF As Boolean    '窗体是否卸载
Public P_RecordCount As Integer '记录条数
Public YesNo_str As String
Public SsqlHelp As String
Public P_Code As String: Public P_Name As String  '编码、名称
Public AddExit_TF As Boolean '添加或编辑状态

Public P_Ssql As String  'Sql 语句

'引用API函数
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'变量声明begin 2002-10-21 add 4 new Operate & Access Right
Public ServerName As String
Public Xt_RoleCode As String
Public gBillId As String
Private LocalIP As String
Public Const Ebo_gsProductName = "Ebodiy2008"       '统一使用，不可修改
Public Const Ebo_gsPrjName = "Gen13301481112"        '工程项目名称，根据项目和版本号修改
Public str_right(7) As String
'1单据索引、2单据名称、3功能索引、4角色代码、5单据号、6单据id号、7提示信息
Public str_billsql As String     '显示单据的字符串,用于判断对当前单据有权限的角色
'变量声明end 2002-10-21
'Public Const hx_RecCount = 1000      '查询结果显示记录条数
Public hx_RecCount As Long  '查询结果显示记录条数

'图标
Public Enum enumIcon
   ebodiyError = 1        '错误
   ebodiyQuery = 2        '询问
   ebodiyWarning = 3      '警告
   ebodiyInfomation = 4   '信息
End Enum

'信息框类型
Public Enum enumMsgType
   ebodiyOKOnly = 0       '确定
   ebodiyOkCancel = 2     '确定/取消
   ebodiyYesNo = 1        'Yes/No
End Enum


Public Enum SortOfForms
      ebodiyBasicForm = 0
      ebodiyBillForm = 1
End Enum

Public Function Strcdcs(Lrcsstr As String, Lrzdcd As Integer) As Integer                            '测量并限制字符串长度(汉字与字符区分)
   
    '参数说明:Lrcsstr 需要测量和限制输出的字符串 Lrzdcd 限制输出长度
  
    lrtextlong = Len(Trim(Lrcsstr))
    lrcscd = 0
    For jsqte = 1 To lrtextlong
        lrcszf = Mid(Lrcsstr, jsqte, 1)
        lrzzcd = lrcscd
        If Asc(lrcszf) >= 0 And Asc(lrcszf) <= 255 Then
            lrcscd = lrcscd + 1
        Else
            lrcscd = lrcscd + 2
        End If
        If lrcscd > Lrzdcd Then
            lrstrjqcd = jsqte - 1
            Lrcsstr = Mid(Lrcsstr, 1, lrstrjqcd)
            Strcdcs = lrzzcd
            Exit Function
        Else
            Strcdcs = lrcscd
        End If
    Next jsqte

End Function

'======================以下为文本录入内容格式输入控制过程函数======================='
Public Sub Lrfzszxz(Sjwb As TextBox, lrzfasc As Integer)              '文本框录入整数值(负)限制
   
    '输入参数：sjwb 录入限制文本框 lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or lrzfasc = vbKeyBack Or (Chr(lrzfasc) = "-" And Sjwb.SelStart = 0)) Then
        lrzfasc = 0
    End If

End Sub

Public Sub Lrzszxz(lrzfasc As Integer)                                '文本框录入整数值(正)限制
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If

End Sub

Public Sub Lrszzfxz(lrzfasc As Integer)                               '文本框录入数字及字符限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or (lrzfasc >= Asc("a") And lrzfasc <= Asc("z")) Or (lrzfasc >= Asc("A") And lrzfasc <= Asc("Z")) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If

End Sub

Public Sub Lrfhzxz(lrzfasc As Integer)                                '文本框录入非汉字限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= 0 And lrzfasc <= 255) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If

End Sub

Public Sub Lrrqxz(lrzfasc As Integer)                                 '文本框录入日期限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or Chr(lrzfasc) = "-" Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
    
End Sub

Public Sub Lrxszxz(Sjwb As TextBox, lrzfasc As Integer)               '文本框录入带有小数位及正负号数值字段
  
    If Not ((Chr(lrzfasc) >= "0" And Chr(lrzfasc) <= "9") Or (Chr(lrzfasc) = "." And InStr(1, Sjwb.Text, ".") = 0) Or lrzfasc = vbKeyBack Or (Chr(lrzfasc) = "-" And Sjwb.SelStart = 0)) Then
        lrzfasc = 0
    End If

End Sub

Public Sub Lrxzszxz(Sjwb As TextBox, lrzfasc As Integer)              '文本框录入带有小数位正>=0数值字段
    
    If Not ((Chr(lrzfasc) >= "0" And Chr(lrzfasc) <= "9") Or (Chr(lrzfasc) = "." And InStr(1, Sjwb.Text, ".") = 0) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If

End Sub

'5.04
'Public Sub Sjgskz(Sjwb As TextBox, zsws As Integer, xsws As Integer)  '保证数值录入字段录入格式
'
'    '输入参数:sjwb 录入限制文本框 zsws 数值录入限制整数位数 xsws 数值录入限制小数位数
'
'    Dim xsdwz%, bccrd%
'    xsdwz = InStr(1, Sjwb.Text, ".")
'    bccrd = Sjwb.SelStart
'    If xsdwz = 0 Then
'        Sjwb.Text = Mid(Sjwb.Text, 1, zsws)
'        Sjwb.SelStart = bccrd
'        Exit Sub
'    End If
'    If zsws > xsdwz - 1 Then
'        Zswstr = Mid(Sjwb, 1, xsdwz - 1)
'    Else
'        Zswstr = Mid(Sjwb, 1, zsws)
'    End If
'    Xswstr = Mid(Sjwb, xsdwz + 1, xsws)
'    Sjwb = Zswstr + "." + Xswstr
'    Sjwb.SelStart = bccrd
'
'End Sub

Public Sub Sjgskz(Sjwb As TextBox, zsws As Integer, xsws As Integer)  '保证数值录入字段录入格式

    '输入参数:sjwb 录入限制文本框 zsws 数值录入限制整数位数 xsws 数值录入限制小数位数
   
   Dim bccrd%
   Dim Ws, Zswstr, Xswstr As String
   Dim B_fu As Boolean
   Dim sjzws As Integer

   bccrd = Sjwb.SelStart
   B_fu = False
   
    Ws = InStr(1, Sjwb, "-")
    If Ws > 0 Then Sjwb = Mid(Sjwb, Ws)

   If Left(Sjwb, 1) = "-" Then
      B_fu = True
      zsws = zsws - 1
      Zswstr = Mid(Sjwb, 2)
   Else
      Zswstr = Mid(Sjwb, 1)
   End If
   
   Ws = InStr(1, Zswstr, ".")                   '整数位数+1
   
    If Ws > 0 Then
        If zsws > Ws - 1 Then
            Zswstr = Mid(Zswstr, 1, Ws - 1) + Mid(Zswstr, Ws, xsws + 1)
        Else
            Zswstr = Mid(Zswstr, 1, zsws) + Mid(Zswstr, Ws, xsws + 1)
            Ws = InStr(1, Zswstr, ".")                   '整数位数+1
        End If
        Ws = Len(Zswstr) - Ws                   '小数位数
        If Left(Zswstr, 1) = "." Then
            bccrd = bccrd + 1
            Zswstr = "0" & Zswstr
        End If
        If Ws < xsws Then
           Zswstr = Format(Zswstr, "#0." + String(Ws, "0"))
        Else
           Zswstr = Format(Zswstr, "#0." + String(xsws, "0"))
        End If
   Else
      Zswstr = Mid(Zswstr, 1, zsws)
      Zswstr = Format(Zswstr)
   End If
   
   If B_fu Then
       Zswstr = "-" & Zswstr
       zsws = zsws + 1
   End If

   Sjwb = Zswstr
   Sjwb.SelStart = bccrd

End Sub

Public Sub InputFieldLimit(Ydtextte As TextBox, Zdsjlxte As Integer, KeyAsciite As Integer)     '录入字段事中控制程序

    '函数参数:录入限制文本框,字段数据类型,录入字符
    Select Case Zdsjlxte
        Case 1                                  '1-录入(Ascii0-255)
            Call Lrfhzxz(KeyAsciite)
        Case 2
            Call Lrszzfxz(KeyAsciite)             '2-录入(0-9,a-z,A-Z)
        Case 3
            Call Lrfzszxz(Ydtextte, KeyAsciite)   '3-录入整数值(正负)
        Case 4
            Call Lrzszxz(KeyAsciite)              '4-录入整数值(正)
        Case 5, 8, 9
            Call Lrxszxz(Ydtextte, KeyAsciite)    '5-录入小数值(正负) 8-金额型(正负) 9-数量型（正负）
        Case 6, 10, 11, 12
            Call Lrxzszxz(Ydtextte, KeyAsciite)   '6-录入小数值(正) 10-单价型 11-金额型(正) 12-数量型（正）
        Case 7
            Call Lrrqxz(KeyAsciite)               '7-录入日期
    End Select

End Sub
Public Sub TextChangeLimit(Ydtextte As TextBox, Zdsjlxte As Integer)      '文本框字段录入控制(事后、防止用户采用粘贴录入)
    '函数参数:录入限制文本框,字段数据类型
    
    Dim Str_JudgeStr As String      '判断字符
    Dim jsqte As Integer           '临时使用计数器
    Dim Str_Result As String        '结果字符串
    Dim KeyAsciite As Integer
    
    Str_Result = ""
    
    For jsqte = 1 To Len(Trim(Ydtextte.Text))
        Str_JudgeStr = Mid(Trim(Ydtextte.Text), jsqte, 1)
        KeyAsciite = Asc(Str_JudgeStr)
    
        If Str_JudgeStr = "'" Then
           Str_JudgeStr = ""
        End If
        
        Select Case Zdsjlxte
            Case 1                                           '1-录入(Ascii0-255)
                Call Lrfhzxz(KeyAsciite)
                If KeyAsciite = 0 Then
                   Str_JudgeStr = ""
                End If
            Case 2
                Call Lrszzfxz(KeyAsciite)                    '2-录入(0-9,a-z,A-Z)
                If KeyAsciite = 0 Then
                   Str_JudgeStr = ""
                End If
            Case 4, 6, 10, 11, 12
                If Str_JudgeStr = "-" Then                   '录入数值(正)
                   Str_JudgeStr = ""
                End If
                
        End Select
        Str_Result = Str_Result + Str_JudgeStr
     Next jsqte
     
     If Str_Result <> Trim(Ydtextte.Text) Then
        Ydtextte.Text = Str_Result
        Ydtextte.SelStart = Len(Ydtextte.Text)
     End If
     '2003-12-08 by lg
     If Zdsjlxte = 4 Or Zdsjlxte = 6 Or Zdsjlxte = 10 Or Zdsjlxte = 11 Or Zdsjlxte = 12 Then
        If Not IsNumeric(Ydtextte) Then Ydtextte.Text = ""
     End If
     'end
End Sub

Public Function Kjjdzy(Zyjdzs As Integer) As Boolean                                    '控件焦点转移(针对回车键)
    Kjjdzy = False
    On Error Resume Next
    If Screen.ActiveControl.TabIndex <= Zyjdzs - 1 Then
        Kjjdzy = True
        SendKeys "{tab}"
    End If
End Function

Public Sub Pbwxzf(Zfc As Integer)                                                       '录入时屏蔽"'"
    If Chr(Zfc) = "'" Then
        Zfc = 0
    End If
End Sub

Public Sub F1bz()                                                                           '发送F1键
    SendKeys "{F1}"
End Sub

Public Sub Textyx(Textte As TextBox)                                                        '文本框有效
    
    Textte.Enabled = True
    Textte.BackColor = &H80000005

End Sub

Public Sub Textwx(Textte As TextBox)                                                        '文本框无效
   
    Textte.Enabled = False
    Textte.BackColor = &HC0C0C0

End Sub

'//* 功能: 金额小写转换为大写  调用参数:jesj...人民币小写金额
'//* 返回变量: name..人民币大写金额
Public Function Fun_Jezh(Jesj As Double) As String
    
    Dim Name1$, Name2$, Mje1$, Name$
    Dim len_mje1%, k%, Ws%, j%, ws1%, m%
    Dim Bz As Boolean
    Name1 = "壹贰叁肆伍陆柒捌玖"
    Name2 = "分角元拾佰仟万拾佰仟亿拾佰仟"
    Mje1 = Trim(Format(Jesj, "###.00"))
    len_mje1 = Len(Mje1)
    If len_mje1 > 16 Or Jesj < 0.01 Or IsNull(Jesj) Then
        Fun_Jezh = ""
        Exit Function
    End If
    '//取无小数的字符串
    Mje1 = Left(Mje1, len_mje1 - 3) + Right(Mje1, 2)
    len_mje1 = len_mje1 - 1
    k = len_mje1 * 2 - 1
    Ws = Int(Mid(Mje1, 1, 1)) * 2 - 1

    If len_mje1 = 3 And Ws < 0 Then     '//如果金额<1 name=''
        Name = ""
    Else
        If Ws > 0 Then
            Name = MidB(Name1, Ws, 2) + MidB(Name2, k, 2) '//如果金额>=1,转换金额
        End If
    End If
    j = 2
    k = k - 2
    Bz = True