inimodule.bas

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

Attribute VB_Name = "IniModule"
'访问INI
'   ReadINI   读INI
'   WriteINI  写INI
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal AppName As String, _
ByVal Keyname As String, ByVal keydefault As String, _
ByVal Filename As String) As Long

Public Function ReadINI(inifile, inisection, inikey, iniDefault) As String
'如果没有section (appname),默认为第一
'如果没有key,则默认为第一
    Dim lpApplicationName As String, lpKeyName As String, _
    lpDefault As String, lpReturnedString As String, _
    lpFileName As String, Filename As String
    Dim nSize As Long, RetVal As Long
    lpDefault = Space$(254)
    lpDefault = iniDefault

    lpReturnedString = Space$(254)

    nSize = 254
    lpFileName = inifile
    lpApplicationName = inisection
    lpKeyName = inikey
    Filename = lpFileName
    RetVal = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName)
    ReadINI = lpReturnedString
    
End Function

Public Function WriteINI(inifile As String, inisection As String, inikey As String, Info As String) As String
    Dim RetVal As Long
    RetVal = WritePrivateProfileString(inisection, inikey, Info, inifile)
    WriteINI = LTrim$(str$(RetVal))
End Function

'判断文件是否存在
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)) = 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
    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)
   Private 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 StringEnDeCodecn(strSource As String, MA) As String
'该函数只对中西文起到加密作用
'参数为：源文件，密码
On Error GoTo ErrEnDeCode
Dim X As Single
Dim CHARNUM As Long, RANDOMINTEGER 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

'一个是字符串到字节的转化,一个是字节到字符串的转化.
Public Function stringtoarray(ByVal str As String) As Variant
Dim i As Long
Dim j As Long
Dim arr() As Byte
i = Len(str)
ReDim arr(i) As Byte
For j = 0 To i - 1
arr(j) = CByte(Asc(Mid(str, j + 1, 1)))
Next
stringtoarray = arr()
End Function

Public Function bytetostr(minbyte() As Byte) As String
Dim ml As Integer
Dim basestring As String
Dim tByte As Byte
Dim i As Integer
Dim msendstring As String
Dim moutbyte(4) As Byte
Dim md As Long
Dim linelen As Long
Dim moutbytee(4) As String

md = UBound(minbyte) + 1
md = Len(str)
If md Mod 3 <> 0 Then ReDim Preserve minbyte(md + (2 - (md Mod 3)))
md = md - md Mod 3
If md Mod 3 = 1 Then
    minbyte(UBound(minbyte)) = 0
    minbyte(UBound(minbyte) - 1) = 0
ElseIf md Mod 3 = 2 Then
    minbyte(UBound(minbyte)) = 0
End If

linelen = 0

For ml = 0 To UBound(minbyte) - 2 Step 3
    DoEvents
    tByte = minbyte(ml) And &HFC
    moutbyte(0) = tByte / 4
    tByte = ((minbyte(ml) And &H3) * 16) + (minbyte(ml + 1) And &HF0) / 16
    moutbyte(1) = tByte
    tByte = ((minbyte(ml + 1) And &HF) * 4) + ((minbyte(ml + 2) And &HC0) / 64)
    moutbyte(2) = tByte
    tByte = (minbyte(ml + 2) And &H3F)
    moutbyte(3) = tByte
    basestring = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    For i = 0 To 3
        moutbytee(i) = Mid(basestring, moutbyte(i) + 1, 1)
    Next i
    msendstring = msendstring & moutbytee(0) & moutbytee(1) & moutbytee(2) & moutbytee(3)
    linelen = linelen + 1
    If linelen * 4 > 74 Then
        msendstring = msendstring & vbCrLf
        linelen = 0
    End If
Next

md = md Mod 3
If md = 1 Then msendstring = Left(msendstring, Len(msendstring) - 2) & "=="
If md = 2 Then msendstring = Left(msendstring, Len(msendstring) - 1) & "="
bytetostr = msendstring

End Function