strmodule.bas

adsl拨号工具 有很多功能 不错啊 大家试试

Attribute VB_Name = "StrModule"
'****************************************************************************
'人人为我，我为人人
'枕善居汉出品
'发布日期：05/08/15
'描  述：拨号上网管理器
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
Option Explicit
'判断文件是否存在
Function FileExists(fname$) As Boolean
    On Error Resume Next
    Dim FreeX As Integer
 
    FreeX = FreeFile
    Open fname$ For Input As FreeX
    If Err = 0 Then
        FileExists = True
    Else
        FileExists = False
    End If
    Close FreeX
End Function

'最新解密函数
Public Function Decrypt(PlainStr As String, key As String) As String
    Dim Char As String, KeyChar As String, NewStr As String
    Dim Pos As Integer
    Dim I As Integer, Side1 As String, Side2 As String
    Pos = 1
    If Len(PlainStr) Mod 2 = 0 Then
            Side1 = StrReverse(Left(PlainStr, (Len(PlainStr) / 2)))
            Side2 = StrReverse(Right(PlainStr, (Len(PlainStr) / 2)))
            PlainStr = Side1 & Side2
    End If
    For I = 1 To Len(PlainStr)
            Char = Mid(PlainStr, I, 1)
            KeyChar = Mid(key, Pos, 1)
            NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
            If Pos = Len(key) Then Pos = 0
            Pos = Pos + 1
    Next I
    Decrypt = NewStr
End Function
   
'最新加密函数
Public Function Encrypt(PlainStr As String, key As String) As String
    Dim Char As String, KeyChar As String, NewStr As String
    Dim Pos  As Integer
    Dim I As Integer, Side1 As String, Side2 As String
    Pos = 1
    For I = 1 To Len(PlainStr)
            Char = Mid(PlainStr, I, 1)
            KeyChar = Mid(key, Pos, 1)
            NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
            If Pos = Len(key) Then Pos = 0
            Pos = Pos + 1
    Next I
    If Len(NewStr) Mod 2 = 0 Then
            Side1 = StrReverse(Left(NewStr, (Len(NewStr) / 2)))
            Side2 = StrReverse(Right(NewStr, (Len(NewStr) / 2)))
            NewStr = Side1 & Side2
    End If
    Encrypt = NewStr
End Function

'去除汉字的空格
Public Function conv_str(mystring As String) As String
Dim I As Integer
Dim temp_string As String
    temp_string = ""
    For I = 0 To Len(mystring) - 1
       If Asc(Mid(mystring, I + 1, 1)) < 0 Or Asc(Mid(mystring, I + 1, 1)) > 64 Or Asc(Mid(mystring, I + 1, 1)) = 48 Or Asc(Mid(mystring, I + 1, 1)) = 49 Or Asc(Mid(mystring, I + 1, 1)) = 50 Or Asc(Mid(mystring, I + 1, 1)) = 51 Or Asc(Mid(mystring, I + 1, 1)) = 52 Or Asc(Mid(mystring, I + 1, 1)) = 53 Or Asc(Mid(mystring, I + 1, 1)) = 54 Or Asc(Mid(mystring, I + 1, 1)) = 55 Or Asc(Mid(mystring, I + 1, 1)) = 56 Or Asc(Mid(mystring, I + 1, 1)) = 57 Then
             temp_string = temp_string & Mid(mystring, I + 1, 1)
       End If
    Next
    conv_str = temp_string
End Function

'去除为零
Public Function selestr(mystring As String) As String
Dim I As Integer
Dim temp_string As String
    temp_string = ""
    For I = 0 To Len(mystring) - 1
       If Asc(Mid(mystring, I + 1, 1)) = 0 Then
          Exit For
       End If
       
       If Asc(Mid(mystring, I + 1, 1)) < 0 Or Asc(Mid(mystring, I + 1, 1)) > 64 Or Asc(Mid(mystring, I + 1, 1)) = 45 Or Asc(Mid(mystring, I + 1, 1)) = 46 Or Asc(Mid(mystring, I + 1, 1)) = 47 Or Asc(Mid(mystring, I + 1, 1)) = 48 Or Asc(Mid(mystring, I + 1, 1)) = 49 Or Asc(Mid(mystring, I + 1, 1)) = 50 Or Asc(Mid(mystring, I + 1, 1)) = 51 Or Asc(Mid(mystring, I + 1, 1)) = 52 Or Asc(Mid(mystring, I + 1, 1)) = 53 Or Asc(Mid(mystring, I + 1, 1)) = 54 Or Asc(Mid(mystring, I + 1, 1)) = 55 Or Asc(Mid(mystring, I + 1, 1)) = 56 Or Asc(Mid(mystring, I + 1, 1)) = 57 Or Asc(Mid(mystring, I + 1, 1)) = 58 Then
             temp_string = temp_string & Mid(mystring, I + 1, 1)
       End If
    Next
    selestr = temp_string
End Function

'检测所含字符中的汉字数
Public Function Checkstr(mystring As String) As Integer
Dim I As Integer
Dim Temp As String
Dim s As String
Dim count_hz As Integer
    Temp = ""
    count_hz = 0
    For I = 0 To Len(mystring) - 1
       If Asc(Mid(mystring, I + 1, 1)) < 0 Then
             count_hz = count_hz + 1
             s = s & Mid(mystring, I + 1, 1)
       End If
    Next
    Checkstr = count_hz
End Function


'************************************************************************************
   '下面的函数可以去掉文中多余的回车和空行，可以对付非常规的字符(以0Ah作为回车，而不是0Dh,0Ah)
   Public Function FormatStr(strReadyToFormat As String) As String
   Dim strTemp() As String
   Dim strReady As String
   Dim nPos As Long
   Dim I As Long
   On Error Resume Next
   'Do
       DoEvents
       '有的文件以0Ah作为回车换行标志
       nPos = InStr(1, strReadyToFormat, Chr(10), vbBinaryCompare)
       '找到0AH后，表示准备另起一行，先将之前的字符0Dh取出(如果有的话)，0Dh表示回车
       strReady = Left(strReadyToFormat, nPos - 1)
       '如果前面有0DH，全部去掉
       Do While Asc(Right(strReady, 1)) = 13
           strReady = Left(strReady, Len(strReady) - 1)
           If strReady = "" Then Exit Do
       Loop
       '检查是不是一个空行
       If Trim(strReady) <> "" Then
           '若是，则写入
           I = I + 1
           ReDim Preserve strTemp(I)
           strTemp(I) = strReady
       End If
       '去掉头部的字符串
       strReadyToFormat = Right(strReadyToFormat, Len(strReadyToFormat) - nPos)
   'Loop Until nPos = 0 '继续向下找
   FormatStr = ""
   For I = 1 To UBound(strTemp)
       FormatStr = FormatStr + strTemp(I)
   Next
   End Function

Public Function DelH(sTR As String) As String
   Dim II As Integer, I As Integer
   II = Len(sTR)
   For I = 1 To II
       If Asc(Right(sTR, I)) <> 13 Then
          DelH = DelH + Right(sTR, 1)
       End If
   Next
End Function

   
   
Public Function StringEnDeCodecn(strSource As String, MA) As String
'该函数只对中西文起到加密作用
'参数为：源文件，密码
On Error GoTo ErrEnDeCode
Dim X As Single
Dim CHARNUM As Long, RANDOMINTEGER As Integer, I As Integer
Dim SINGLECHAR As String * 1
Dim strTmp As String
If MA < 0 Then
MA = MA * (-1)
End If
X = Rnd(-MA)
For I = 1 To Len(strSource) Step 1 '取单字节内容
SINGLECHAR = Mid(strSource, I, 1)
CHARNUM = Asc(SINGLECHAR)
g: RANDOMINTEGER = Int(127 * Rnd)
If RANDOMINTEGER < 30 Or RANDOMINTEGER > 100 Then GoTo g
CHARNUM = CHARNUM Xor RANDOMINTEGER
strTmp = strTmp & Chr(CHARNUM)
Next I
StringEnDeCodecn = strTmp
Exit Function
ErrEnDeCode:
StringEnDeCodecn = ""
MsgBox Err.Number & "\" & Err.Description
End Function

'----------------------------
'文本框格式限制函数
'用法:
'在Text的keypress事件中加入 KeyAscii = ValiText(KeyAscii, "0123456789.", True)
'0123456789.为允许接受的字符
'-----------------------------
Public Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer '密码设置
Dim ValidateList As String
Dim KeyOut As Integer
If Editable = True Then
ValidateList = UCase(ValidateString) & Chr(8)
Else
ValidateList = UCase(ValidateString)
End If
If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
KeyOut = KeyIn
Else
KeyOut = 0
Beep
End If
ValiText = KeyOut
End Function

'获取文件扩展名
Public Function GetExtension(Filename As String)
    Dim PthPos As Integer, ExtPos As Integer, I As Integer, J As Integer
    For I = Len(Filename) To 1 Step -1
        If Mid(Filename, I, 1) = "." Then
           ExtPos = I
           For J = Len(Filename) To 1 Step -1
               If Mid(Filename, J, 1) = "\" Then
                  PthPos = J
                  Exit For
               End If
           Next J
           Exit For
        End If
    Next I
    If PthPos > ExtPos Then
       Exit Function
    Else
       If ExtPos = 0 Then Exit Function
       GetExtension = Mid(Filename, ExtPos + 1, Len(Filename) - ExtPos)
    End If
End Function