系统_基本函数模块.bas

适合于中小型企业管理

            .AddItem Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + jsqte)), 2, 2)
        Next jsqte
     
        .Text = Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + Period)), 2, 2)
    End With

End Function
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 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
            End If
            If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
                GetPY = GetPY + "X"
                GoTo L1
            End If
            If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
                GetPY = GetPY + "Y"
                GoTo L1
            End If
            If Asc(t1) >= Asc("匝") Then
                GetPY = GetPY + "Z"
                GoTo L1
            End If
        Else
            If UCase(t1) <= "Z" And UCase(t1) >= "A" Then
                GetPY = GetPY + UCase(t1)
            Else
                GetPY = t1
            End If
        End If
L1:
    Next jsqte

End Function



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

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 Function MachineName() As String                                         '取得当前工作站名
    Dim hostname As String * 256
    
    If gethostname(hostname, 256) = -1 Then
        MachineName = "(未知)"
    Else
        hostname = Trim$(hostname)
        MachineName = Left$(hostname, InStr(hostname, vbNullChar) - 1)
    End If

End Function

Public Function LocalIP() As String                                         '取得当前工作站IP地址
    Dim hostname As String * 256
    Dim hostent_addr As Long
    Dim host As HOSTENT
    Dim hostip_addr As Long
    Dim temp_ip_address() As Byte
    Dim i As Integer

    If gethostname(hostname, 256) = -1 Then
        LocalIP = "0"
        Exit Function
    Else
        hostname = Trim$(hostname)
    End If

    hostent_addr = gethostbyname(hostname)
    
    RtlMoveMemory host, hostent_addr, LenB(host)
    RtlMoveMemory hostip_addr, host.hAddrList, 4

    If hostip_addr = 0 Then
        LocalIP = "0"
        Exit Function
    End If

    ReDim temp_ip_address(1 To 4)
    RtlMoveMemory temp_ip_address(1), hostip_addr, 4
    For i = 1 To 4
        LocalIP = LocalIP & temp_ip_address(i) & "."
    Next
    LocalIP = Mid$(LocalIP, 1, Len(LocalIP) - 1)

    
End Function

Public Sub Register_OnlineUser(InOut As Boolean)
'修改在线用户表，参数true 登陆（同一用户只允许一次登录），false 退出
       
End Sub

'==============================================================================='
Public Function GSdate() As Date  '服务器系统日期函数
    Dim RsGdate As ADODB.Recordset
    Set RsGdate = New Recordset
    
    RsGdate.Open "select getdate() as Gdate", Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
    GSdate = Year(RsGdate!Gdate) & "-" & Month(RsGdate!Gdate) & "-" & Day(RsGdate!Gdate)
    RsGdate.Close
    Set RsGdate = Nothing
End Function

Public Function BoolDate(GCdate As Date) As Boolean  '服务器系统日期与登陆日期对比函数
If Day(GSdate) > 28 Then
    If Year(GSdate) = Year(GCdate) And Month(GSdate) = Month(GCdate) And Day(GCdate) > 20 Then
        BoolDate = True
    Else
        BoolDate = False
    End If
Else
    If Year(GSdate) = Year(GCdate) And Month(GSdate) = Month(GCdate) Then
        BoolDate = True
    ElseIf Year(GSdate) = Year(GCdate) And Month(GSdate) = Month(GCdate) + 1 And Day(GCdate) > 20 Then
        BoolDate = True
    ElseIf Year(GSdate) = Year(GCdate) + 1 And Month(GCdate) = 12 And Day(GCdate) > 20 Then
        BoolDate = True
    End If
End If
End Function