systemmodule.bas

即时通讯

    Dim HzNum As Integer
    
    l = Len(HzStr$)
    
    For n = 1 To l
    
        If Asc(Mid$(HzStr$, n, 1)) < 0 Then
            HzNum = HzNum + 1
        End If
    
    Next n
    
    CLen = l + HzNum

End Function

Public Sub test()
    MainForm.g_msgText = "test"
End Sub

'======================以下为文本录入内容格式输入控制过程函数======================='
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

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

End Sub
'**************************************
'*    功 能 描 述 :判断一个用户是否有权限执行一个操作(用户权限判断)
'*    输 入 参 数 :id  --  用户的ID
'*                 cs  --  权限的编号
'*    输 出 能 数 :true  -  有这个权限
'*                 false -  没有这个权限
'**************************************
Public Function yhqxpd(id As String, cs As String) As Boolean
    Dim m_EmployeeDAO As employeeDAO ' 数据库操作类
    Dim m_recordset As ADODB.Recordset ' 数据操作数据集对象

    Set m_EmployeeDAO = New employeeDAO
    Set m_recordset = New ADODB.Recordset
    yhqxpd = False
    m_EmployeeDAO.show_employeepermission1 m_recordset, id, cs      '获得商品名称列表
        With m_recordset
                If Not .EOF Then
                    yhqxpd = True
                Else
                    yhqxpd = False
                End If
        End With
    m_recordset.Close
End Function
'**************************************
'*    功 能 描 述 :根据报表名和记录ID打印报表
'*    输 入 参 数 :reportName  --  报表的名称
'*                 recordId    --  记录ID字符串
'*    输 出 能 数 :
'**************************************
Public Function PrintCrystalReport(reportName As String, _
                                   recordId As String)
    Dim Report As CrystalForm        ' 打印窗体
    
    Set Report = New CrystalForm
    
    If Trim(recordId) = "" Then      ' 如果没有选择员工则提示错误
        MainForm.g_msgText = "请选择记录然后再执行打印操作!"
        HMsgBox MainForm.g_msgText, 0, 1
    Else
        Report.PrintReport reportName, recordId
        Report.show 1
    End If

    Set Report = Nothing
End Function