系统_基本函数模块.bas

适合于中小型企业管理

           Xtxxts = MsgBox(xttsxx, vbYesNo + Tbtslb * 16, msgtitle)
        Case 2    '确定/取消
           Xtxxts = MsgBox(xttsxx, vbOKCancel + Tbtslb * 16, msgtitle)
        Case Else
           Xtxxts = "9"
    End Select
End Function


Public Function Kjjdzy(Zyjdzs As Integer) As Boolean                                    '控件焦点转移(针对回车键)
    
    Kjjdzy = False
    
    On Error GoTo Cwcl
    
    If Screen.ActiveControl.TabIndex <= Zyjdzs - 1 Then
        Kjjdzy = True
        SendKeys "{tab}"
    End If
    Exit Function
Cwcl:
    Resume Next         '有些对象不支持TabIndex属性
    
End Function

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

Public Function Encrypt(src As String) As String
Dim i As Integer
Dim aStr As String
Dim num1, num2 As Double
For i = 1 To Len(src)
    aStr = aStr + CStr(Asc(Mid(src, i, 1)))
Next
num1 = Val(aStr)
num2 = Int(num1 * num1 / 3) + num1
If num2 = 0 Then
    Encrypt = ""
Else
    Encrypt = CStr(num2)
End If
End Function

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


Public Sub Sub_SetOperStatus(Str_OperStatus As String)                                                   '显示系统操作状态
    
    If Trim(Str_OperStatus) <> "" Then
        XT_Main.StatusBar1.Panels("OperStatus") = Str_OperStatus
    Else
        XT_Main.StatusBar1.Panels("OperStatus") = "就绪"
    End If
    
End Sub

'===================以下为系统权限控制与上机日志控制函数======================'
Public Function Security_Log(gnsy As String, UserCode As String, Optional LogTF As Integer = 3, Optional state As Boolean = True) As Boolean   '权限判断和日志
    
    'Gnsy 功能索引 UserCode 用户编码
    'LogTF (1、判断权限，写日志)、（2、只写日志）、（3、只判断权限）
    'State 状态 (True 进入 false 完成)
    '返回Security_Log=true表示有权限，Security_Log=false表示没有有权限
    
    Dim Tsxx As String              '系统信息提示
    
    On Error Resume Next
    
    Dim aDo_userGroup As New Recordset
    Dim aDo_gnbm As New Recordset: Dim sSql As String
    
    Set aDo_gnbm = Cw_DataEnvi.DataConnect.Execute("select * from Xt_xtgnb where gnsy='" & Trim(gnsy) & "'")
    
    If LogTF = 1 Or LogTF = 3 Then
        Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Czygl where czybm='" & Trim(UserCode) & "'")
        
        If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
            Security_Log = True
        Else
            Security_Log = False
        End If
        aDo_userGroup.Close
        Set aDo_userGroup = Nothing
        
        If Security_Log = False Then
            Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from System_UserGroupInfo a ,System_UserGroup b where a.groupid=b.groupid and a.userid=" & Trim(UserCode))
            Do While Not aDo_userGroup.EOF
                If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
                    Security_Log = True
                    Exit Do
                Else
                    Security_Log = False
                End If
                aDo_userGroup.MoveNext
            Loop
            aDo_userGroup.Close
            Set aDo_userGroup = Nothing
        End If
        If Security_Log = False Then
            Tsxx = "没有权限,请与管理员联系！   "
            Call Xtxxts(Tsxx, 0, 4)
        End If
    End If
    
    '------------------------------------
    If (LogTF = 1 And Security_Log = True) Or LogTF = 2 Then
        If state = True Then
            sSql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
            & " values(getdate()," & UserCode & ",'" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "系统管理" & "','" & NTDomainUserName & "','进入')"
        Else
            sSql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
            & " values(getdate()," & UserCode & ",'" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "系统管理" & "','" & NTDomainUserName & "','完成')"
        End If
        Cw_DataEnvi.DataConnect.Execute sSql
    End If
    aDo_gnbm.Close
    Set aDo_gnbm = Nothing
    
End Function

Public Function MachineName() As String                                         '取得当前工作站名
    
    Dim sBuffer As String * 255
    If GetComputerName(sBuffer, 255&) <> 0 Then
        MachineName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    Else
        MachineName = "(未知)"
    End If
    
End Function

Public Function NTDomainUserName() As String                                    '取得当前网络用户名
    
    Dim strBuffer As String * 255
    Dim lngBufferLength As Long
    Dim lngRet As Long
    Dim strTemp As String
    
    lngBufferLength = 255
    lngRet = GetUserName(strBuffer, lngBufferLength)
    strTemp = UCase(Trim$(strBuffer))
    NTDomainUserName = Left$(strTemp, lngBufferLength - 1)
    
End Function

Public Function GetPY(a1 As String) As String                                   '返回拼音码字符串
    
    '输入参数:a1 输入字符串
    
    Dim Jsqte As Long
    Dim t1 As String
    GetPY = ""
    If Len(Trim(a1)) = 0 Then
        Exit Function
    End If
    For Jsqte = 1 To Len(Trim(a1))
        t1 = Mid(a1, Jsqte, 1)
        If Asc(t1) < 0 Then
            If Asc(t1) < Asc("啊") Then
                GetPY = GetPY + t1
                GoTo L1
            End If
            If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
                GetPY = GetPY + "A"
                GoTo L1
            End If
            If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
                GetPY = GetPY + "B"
                GoTo L1
            End If
            If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
                GetPY = GetPY + "C"
                GoTo L1
            End If
            If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
                GetPY = GetPY + "D"
                GoTo L1
            End If
            If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
                GetPY = GetPY + "E"
                GoTo L1
            End If
            If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
                GetPY = GetPY + "F"
                GoTo L1
            End If
            If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
                GetPY = GetPY + "G"
                GoTo L1
            End If
            If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
                GetPY = GetPY + "H"
                GoTo L1
            End If
            If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
                GetPY = GetPY + "J"
                GoTo L1
            End If
            If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
                GetPY = GetPY + "K"
                GoTo L1
            End If
            If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
                GetPY = GetPY + "L"
                GoTo L1
            End If
            If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
                GetPY = GetPY + "M"
                GoTo L1
            End If
            If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
                GetPY = GetPY + "N"
                GoTo L1
            End If
            If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
                GetPY = GetPY + "O"
                GoTo L1
            End If
            If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
                GetPY = GetPY + "P"
                GoTo L1
            End If
            If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
                GetPY = GetPY + "Q"
                GoTo L1
            End If
            If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
                GetPY = GetPY + "R"
                GoTo L1
            End If
            If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
                GetPY = GetPY + "S"
                GoTo L1
            End If
            If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
                GetPY = GetPY + "T"
                GoTo L1
            End If
            If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
                GetPY = GetPY + "W"
                GoTo L1