外挂编程

开发平台：
Visual Basic

公用模块.bas：源码内容
							Attribute VB_Name = "公用模块"
Declare Function SetProcessWorkingSetSize Lib "KERNEL32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Declare Function GetCurrentProcess Lib "KERNEL32" () As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'读写INI文件
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
Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'二进制转UTF8
Declare Function MultiByteToWideChar Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Declare Function GetTickCount Lib "KERNEL32" () As Long
Declare Function Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
'获取句柄之类的API
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
'获得一个句柄的类名
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
'运行文件
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Const SW_SHOW = 5   '运行文件
Public Const GW_CHILD = 5
Public Const GW_HWNDNEXT = 2
Public Const WM_ACTIVATE = &H6
Public Const HWND_TOPMOST = -1
Public conn As ADODB.Connection
Public httpi As Integer
Public sendhttpi As Integer
'======================================================base64加密======================================================
Public Const base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
'========================= 设置WebBrowser代理 =========================
Private Type INTERNET_PROXY_INFO
    dwAccessType    As Long
    lpszProxy       As String
    lpszProxyBypass As String
End Type
Private Const INTERNET_OPTION_PROXY = 38
Private Const INTERNET_OPTION_SETTINGS_CHANGED = 39
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Declare Function InternetSetOption Lib "wininet.dll" Alias "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, ByRef lpBuffer As Any, ByVal dwBufferLength As Long) As Long
'========================= 设置WebBrowser代理 =========================
'设置声音播放API  ==============
Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Public Const SND_FILENAME = &H20000
Public Const SND_ASYNC = &H1
Public Const SND_SYNC = &H0
'===============================
Private Function Mult(ByVal X As Long, ByVal p As Long, ByVal m As Long) As Long
    y = 1
    On Error GoTo error1
    Do While p > 0
        Do While (p / 2) = (p  2)
            X = (X * X) Mod m
            p = p / 2
        Loop
        y = (X * y) Mod m
        p = p - 1
    Loop
    Mult = y
    Exit Function
error1:
    y = 0
End Function
Public Function Base64_Encode(DecryptedText As String) As String
    On Error Resume Next
    Dim c1, c2, c3 As Integer
    Dim w1 As Integer
    Dim w2 As Integer
    Dim w3 As Integer
    Dim w4 As Integer
    Dim n As Integer
    Dim retry As String
    For n = 1 To Len(DecryptedText) Step 3
        c1 = Asc(Mid$(DecryptedText, n, 1))
        c2 = Asc(Mid$(DecryptedText, n + 1, 1) + Chr$(0))
        c3 = Asc(Mid$(DecryptedText, n + 2, 1) + Chr$(0))
        w1 = Int(c1 / 4)
        w2 = (c1 And 3) * 16 + Int(c2 / 16)
        If Len(DecryptedText) >= n + 1 Then w3 = (c2 And 15) * 4 + Int(c3 / 64) Else w3 = -1
        If Len(DecryptedText) >= n + 2 Then w4 = c3 And 63 Else w4 = -1
        retry = retry + mimeencode(w1) + mimeencode(w2) + mimeencode(w3) + mimeencode(w4)
    Next
    Base64_Encode = retry
End Function
Public Function Base64_Decode(a As String) As String
    On Error Resume Next
    Dim w1 As Integer
    Dim w2 As Integer
    Dim w3 As Integer
    Dim w4 As Integer
    Dim n As Integer
    Dim retry As String
    For n = 1 To Len(a) Step 4
        w1 = mimedecode(Mid$(a, n, 1))
        w2 = mimedecode(Mid$(a, n + 1, 1))
        w3 = mimedecode(Mid$(a, n + 2, 1))
        w4 = mimedecode(Mid$(a, n + 3, 1))
        If w2 >= 0 Then retry = retry + Chr$(((w1 * 4 + Int(w2 / 16)) And 255))
        If w3 >= 0 Then retry = retry + Chr$(((w2 * 16 + Int(w3 / 4)) And 255))
        If w4 >= 0 Then retry = retry + Chr$(((w3 * 64 + w4) And 255))
    Next
    Base64_Decode = retry
End Function
Public Function mimeencode(w As Integer) As String
    If w >= 0 Then mimeencode = Mid$(base64, w + 1, 1) Else mimeencode = ""
End Function
Public Function mimedecode(a As String) As Integer
    If Len(a) = 0 Then mimedecode = -1: Exit Function
    mimedecode = InStr(base64, a) - 1
End Function
Public Function Encode(ByVal Inp As String, ByVal e As Long, ByVal n As Long) As String
    On Error Resume Next
    Dim s As String
    s = ""
    m = Inp
    If m = "" Then Exit Function
    s = Mult(CLng(Asc(Mid(m, 1, 1))), e, n)
    For i = 2 To Len(m)
        s = s & "+" & Mult(CLng(Asc(Mid(m, i, 1))), e, n)
    Next i
    Encode = Base64_Encode(s)
End Function
Public Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n As Long) As String
    On Error Resume Next
    St = ""
    ind = Base64_Decode(Inp)
    For i = 1 To Len(ind)
        nxt = InStr(i, ind, "+")
        If Not nxt = 0 Then
            tok = Val(Mid(ind, i, nxt))
        Else
            tok = Val(Mid(ind, i))
        End If
        St = St + Chr(Mult(CLng(tok), d, n))
        If Not nxt = 0 Then
            i = nxt
        Else
            i = Len(ind)
        End If
    Next i
    Decode = St
End Function
'从字符串到base64字符串
Public Function StrtoBase64(ByVal str As String) As String
    On Error Resume Next
    Dim s1 As String
    Dim m1 As Integer
    s1 = Base64_Encode(str)
    m1 = Len(s1) Mod 4
    If m1 = 3 Then
        s1 = s1 & "="
    ElseIf m1 = 2 Then
        s1 = s1 & "=="
    ElseIf m1 = 1 Then
        s1 = s1 & "==="
    End If
    StrtoBase64 = s1
End Function
'======================================================base64加密======================================================
'==================================================
'===============窗口固顶===========================
Public Sub FormTop(ByVal FormhWnd As Long, Optional ByVal OnOff As Boolean = True)
    '窗口固定
    Dim TopMost As Long, SWP_NOSIZE As Long, SWP_NOMOVE As Long
    SWP_NOSIZE& = &H1 ' 保持窗口大小
    SWP_NOMOVE& = &H2 ' 保持窗口位置
    If OnOff Then
        TopMost = -1
    Else
        TopMost = -2
    End If
    SetWindowPos FormhWnd, TopMost, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub
'===============窗口固顶===========================
'==================================================
'======================================================================
'========================= 设置WebBrowser代理 =========================
Public Function SetProxy(aStrIP As String, aStrPort As String, aBolUseProxy As Boolean)
    Dim strProxy As String
    Dim inf As INTERNET_PROXY_INFO
    
    aStrIP = Trim(aStrIP)
    aStrPort = Trim(aStrPort)
    If (aStrIP + aStrPort = "") Or Not aBolUseProxy Then
      strProxy = ""
    Else
      strProxy = "http=" + aStrIP + ":" + aStrPort
    End If
    
    If Trim(strProxy) <> "" Then
      inf.dwAccessType = INTERNET_OPEN_TYPE_PROXY
      inf.lpszProxy = strProxy
      inf.lpszProxyBypass = ""
      Call InternetSetOption(0, INTERNET_OPTION_PROXY, inf, Len(inf))
      Call InternetSetOption(0, INTERNET_OPTION_SETTINGS_CHANGED, "", 0)
    Else
      inf.dwAccessType = INTERNET_OPEN_TYPE_DIRECT
      inf.lpszProxy = ""
      inf.lpszProxyBypass = ""
    
      Call InternetSetOption(0, INTERNET_OPTION_PROXY, inf, Len(inf))
      Call InternetSetOption(0, INTERNET_OPTION_SETTINGS_CHANGED, "", 0)
    End If
End Function
'========================= 设置WebBrowser代理 =========================
'======================================================================
Function decipher(stext As String)      '加密程序
    Const min_asc = 32
    Const max_asc = 126
    Const num_asc = max_asc - min_asc + 1
    Dim offset As Long
    Dim strlen As Integer
    Dim i As Integer
    Dim ch As Integer
    Dim tem As String
    Randomize Timer
    tem = stext
    If Mid(stext, 1, 5) <> "UU*23" Then
        offset = 513
        Rnd (-1)
        Randomize (offset)
        strlen = Len(stext)
        For i = 1 To strlen
            ch = Asc(Mid(stext, i, 1))
            If ch >= min_asc And ch <= max_asc Then
                ch = ch - min_asc
                offset = Int((num_asc + 1) * Rnd())
                ch = ((ch - offset) Mod num_asc)
                If ch < 0 Then
                    ch = ch + num_asc
                End If
                ch = ch + min_asc
                ptext = ptext & Chr(ch)
            End If
        Next i
        decipher = "UU*23" & ptext
    Else
        decipher = tem
    End If
End Function
Function cipher(stext As String)    '解密程序
    Const min_asc = 32
    Const max_asc = 126
    Const num_asc = max_asc - min_asc + 1
    Dim offset As Long
    Dim strlen As Integer
    Dim i As Integer
    Dim ch As Integer
    Dim tem As String
    Randomize Timer
    tem = stext
    If Mid(stext, 1, 5) = "UU*23" Then
        stext = Mid(stext, 6, Len(stext) - 5)
        offset = 513
        Rnd (-1)
        Randomize (offset)
        strlen = Len(stext)
        For i = 1 To strlen
            ch = Asc(Mid(stext, i, 1))
            If ch >= min_asc And ch <= max_asc Then
                ch = ch - min_asc
                offset = Int((num_asc + 1) * Rnd())
                ch = ((ch + offset) Mod num_asc)
                ch = ch + min_asc
                ptext = ptext & Chr(ch)
            End If
        Next i
        cipher = ptext
    Else
        cipher = tem
    End If
End Function
Function cipher1(stext As String)    '解密程序
    Const min_asc = 32
    Const max_asc = 126
    Const num_asc = max_asc - min_asc + 1
    Dim offset As Long
    Dim strlen As Integer
    Dim i As Integer
    Dim ch As Integer
    Dim tem As String
    Randomize Timer
    tem = stext
    If Mid(stext, 1, 6) = "count:" Then
        stext = Mid(stext, 7, Len(stext) - 6)
        offset = 8681
        Rnd (-1)
        Randomize (offset)
        strlen = Len(stext)
        For i = 1 To strlen
            ch = Asc(Mid(stext, i, 1))
            If ch >= min_asc And ch <= max_asc Then
                ch = ch - min_asc
                offset = Int((num_asc + 1) * Rnd())
                ch = ((ch + offset) Mod num_asc)
                ch = ch + min_asc
                ptext = ptext & Chr(ch)
            End If
        Next i
        cipher1 = ptext
    Else
        cipher1 = tem
    End If
End Function
Public Function UTF8_Decode(bUTF8() As Byte) As String  '二进制解析为UTF8
    Dim lRet     As Long
    Dim lLen     As Long
    Dim lBufferSize     As Long
    Dim sBuffer     As String
    Dim bBuffer()     As Byte
    lLen = UBound(bUTF8) + 1
    If lLen = 0 Then Exit Function
    lBufferSize = lLen * 2
    sBuffer = String$(lBufferSize, Chr(0))
    lRet = MultiByteToWideChar(65001, 0, VarPtr(bUTF8(0)), lLen, StrPtr(sBuffer), lBufferSize)
    If lRet <> 0 Then
        sBuffer = Mid(sBuffer, 1, lRet)
    End If
    UTF8_Decode = sBuffer
End Function
Public Function SaveFileFromRes(vntResourceID As Variant, sType As String, sFileName As String) As Boolean  '释放资源文件
    On Error Resume Next
    Dim bytImage() As Byte
    Dim iFileNum As Integer
    On Error GoTo SaveFileFromRes_Err
    SaveFileFromRes = True
    bytImage = LoadResData(vntResourceID, sType)
    iFileNum = FreeFile
    Open sFileName For Binary As iFileNum
    Put #iFileNum, , bytImage
    Close iFileNum
    Exit Function
SaveFileFromRes_Err:
    SaveFileFromRes = False: Exit Function
End Function
Public Function vbEscape(psString)  'Escape加密
    On Error Resume Next
    Dim nTemp, sTemp, sTempChar, nTempAsc
    For nTemp = 1 To Len(psString)
        sTempChar = Mid(psString, nTemp, 1)
        nTempAsc = AscW(sTempChar)
        If (nTempAsc >= 48 And nTempAsc <= 57) Or (nTempAsc >= 65 And nTempAsc <= 90) Or (nTempAsc >= 97 And nTempAsc <= 122) Or InStr("@*_+-./", sTempChar) > 0 Then
            sTemp = sTemp & sTempChar
        ElseIf nTempAsc > 0 And nTempAsc < 16 Then
            sTemp = sTemp & "%0" & Hex(nTempAsc)
        ElseIf nTempAsc >= 16 And nTempAsc < 256 Then
            sTemp = sTemp & "%" & Hex(nTempAsc)
        Else
            sTemp = sTemp & "u" & Hex(nTempAsc)
        End If
    Next
    vbEscape = sTemp
End Function
Function vbUnEscape(psString)   'Escape解密
    On Error Resume Next
    Dim nTemp, sTemp, sTempChar
    sTemp = ""
    For nTemp = 1 To Len(psString)
        sTempChar = Mid(psString, nTemp, 1)
        If Mid(psString, nTemp, 2) = "u" And nTemp <= Len(psString) - 5 Then
            If IsNumeric("&H" & Mid(psString, nTemp + 2, 4)) Then
                sTemp = sTemp & ChrW(CInt("&H" & Mid(psString, nTemp + 2, 4)))
                nTemp = nTemp + 5
            Else
                sTemp = sTemp & sTempChar
            End If
        ElseIf sTempChar = "%" And nTemp <= Len(psString) - 2 Then
            If IsNumeric("&H" & Mid(psString, nTemp + 1, 2)) Then
                sTemp = sTemp & ChrW(CInt("&H" & Mid(psString, nTemp + 1, 2)))
                nTemp = nTemp + 2
            Else
                sTemp = sTemp & c
            End If
        Else
            sTemp = sTemp & sTempChar
        End If
    Next
    vbUnEscape = sTemp
End Function
Public Function dengji(sum As Long) As Integer  '计算等级
    For i = 0 To 100
        If (i * (i + 1)) * 100 > sum Then
            Exit For
        End If
    Next i
    dengji = i - 1
End Function
Public Function split_m(lx As String, temp As String, K As String) '农场信息分割
    On Error Resume Next
    Dim tem1 As String
    If InStr(temp, K) > 0 Then
        If lx = 1 Then
            tem1 = Split(temp, """" & K & """:")(1)
            split_m = Replace(Split(tem1, ",")(0), """", "")
        ElseIf lx = 2 Then
            tem1 = Split(temp, """" & K & """:")(1)
            split_m = Replace(Split(tem1, "}")(0), """", "")
        ElseIf lx = 3 Then
            tem1 = Split(temp, """" & K & """:""")(1)
            split_m = Split(tem1, """")(0)
        ElseIf lx = 4 Then
            tem1 = Split(temp, K & "=")(1)
            split_m = Split(tem1, ";")(0)
        End If
    Else
        split_m = ""
    End If
End Function
Public Function time_m(T As Long) As String '计算时差   zhonglei(rs.Fields("Kind"), 1) - (time_m - rs.Fields("time"))
    On Error Resume Next
    Dim temp As Long, tem1 As String, tem2 As String, tem3 As String
    temp = T - (DateDiff("s", DateSerial(1970, 1, 1), Now()) - shicha)
    If temp >= 0 Then
        tem1 = temp  3600
        tem2 = (temp Mod 3600)  60
        tem3 = (temp Mod 3600) Mod 60
        time_m = "剩余：" & Format(tem1, "00") & ":" & Format(tem2, "00") & ":" & Format(tem3, "00")
    Else
        time_m = "已收割"
    End If
End Function
Public Function time_mature(T As Long) As String '显示成熟列表
    On Error Resume Next
    Dim temp As Long, tem1 As String, tem2 As String, tem3 As String
    temp = T - (DateDiff("s", DateSerial(1970, 1, 1), Now()) - shicha)
    If temp >= 0 Then
        tem1 = temp  3600
        tem2 = (temp Mod 3600)  60
        tem3 = (temp Mod 3600) Mod 60
        time_mature = Format(tem1, "00") & ":" & Format(tem2, "00") & ":" & Format(tem3, "00")
    Else
        time_mature = "已经成熟"
    End If
End Function
Public Function FromUnixTime(intTime, intTimeZone)
    On Error Resume Next
    If IsEmpty(intTime) Or Not IsNumeric(intTime) Then
         FromUnixTime = Now()
        Exit Function
    End If
    If IsEmpty(intTime) Or Not IsNumeric(intTimeZone) Then intTimeZone = 0
     FromUnixTime = DateAdd("s", intTime, "1970-1-1 0:0:0")
     FromUnixTime = DateAdd("h", intTimeZone, FromUnixTime)
End Function
Public Function Time_C() As Long '获得当前时间
    On Error Resume Next
    Time_C = DateDiff("s", DateSerial(1970, 1, 1), Now())
End Function
Public Function Time_Cx() As Long '计算时差
    On Error Resume Next
    Time_Cx = DateDiff("s", DateSerial(1970, 1, 1), Now()) - shicha
End Function
Public Function Wi()  'Winsock控件数组
    httpi = httpi + 1
    If httpi > 30 Then
        httpi = 0
    End If
    Wi = httpi
End Function
Public Function SHi()  'Winsock控件数组
    sendhttpi = sendhttpi + 1
    If sendhttpi > 30 Then
        sendhttpi = 0
    End If
    SHi = sendhttpi
End Function
Public Function jilu(leixing As String, qq As Long, neirong As String) '记录日志
    On Error Resume Next
    If Val(qq) <> 100 Then
        MkDir App.Path & "伴侣日志"
        MkDir App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & ""
        If Val(qq) > 10000 Then
            MkDir App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & "" & qq
        End If
        If leixing = "删除日志" And neirong = "del" Then
            Kill App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & "" & qq & "" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".txt"
            MsgBox "当天日志文件删除成功!", 64, "提示"
            Exit Function
        End If
        If leixing = "打开日志" And neirong = "open1" Then
            If Dir(App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & "" & qq & "" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".txt") = "" Then
                MsgBox "当天的日志文件不存在,可能已被删除,请进入日志目录查询!", 48, "提醒"
            Else
                ShellExecute Form1.hwnd, "open", Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".txt", 0, App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & "" & qq & "", SW_SHOW
            End If
            Exit Function
        End If
        If leixing = "打开日志" And neirong = "open2" Then
            ShellExecute Form1.hwnd, "open", "", 0, App.Path & "伴侣日志", SW_SHOW
            Exit Function
        End If
        If Val(qq) > 10000 Then
            Open App.Path & "伴侣日志" & Year(Now) & "-" & Month(Now) & "" & qq & "" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".txt" For Append As #1 '打开写入文件
            Print #1, "[" & Format(Hour(time), "00") & ":" & Format(Minute(time), "00") & ":" & Format(Second(time), "00") & "][" & leixing & "]：" & neirong & ""         '写入文件
            Close #1                         '关闭文件
        End If
    End If
    If Form1.List4.ListCount > 1000 Then
        Form1.List4.Clear
    End If
    Form1.List4.AddItem "[" & Format(Hour(time), "00") & ":" & Format(Minute(time), "00") & ":" & Format(Second(time), "00") & "][" & leixing & "]：" & neirong, 0
End Function
Public Function FZDD(loginQQ As Long) As Boolean
    On Error Resume Next
    Dim lngDeskTopHandle As Long
    Dim lngHand As Long
    Dim strName As String * 255
    Dim lngWindowCount As Long
    Dim duodeng As Boolean
    lngDeskTopHandle = GetDesktopWindow()
    lngHand = GetWindow(lngDeskTopHandle, GW_CHILD)
    lngWindowCount = 1
    Do While lngHand <> 0
        strName = ""
        GetWindowText lngHand, strName, Len(strName)
        If InStr(strName, "Mainload|" & loginQQ & "|") > 0 Then
            duodeng = True
            Exit Do
        End If
        lngHand = GetWindow(lngHand, GW_HWNDNEXT)
        lngWindowCount = lngWindowCount + 1
        DoEvents
    Loop
    If duodeng = True Then
        MsgBox "您的QQ:" & loginQQ & "已登录,为了防止被封号,同一个QQ请勿重复登录!  ", 64, "温馨提醒"
        FZDD = True
    Else
        FZDD = False
    End If
End Function
Function UTF8EncodeURI(szInput)  '转换为UTF8编码的URL字符
    On Error Resume Next
    Dim wch, uch, szRet
    Dim X
    Dim nAsc, nAsc2, nAsc3
    If szInput = "" Then
        UTF8EncodeURI = szInput
        Exit Function
    End If
    For X = 1 To Len(szInput)
        wch = Mid(szInput, X, 1)
        If wch = "╲" Then
            szRet = szRet & "%E2%95%B2"
        Else
            If wch = "ˊ" Then
                szRet = szRet & "%CB%8A"
            Else
                If wch = "伱" Then
                    szRet = szRet & "%E4%BC%B1"
                Else
                    If wch = "丫" Then
                        szRet = szRet & "%E4%B8%AB"
                    Else
                        If wch = "╱" Then
                            szRet = szRet & "%E2%95%B1"
                        Else
                            If wch = "╰" Then
                                szRet = szRet & "%E2%95%B0"
                            Else
                                If wch = "˙" Then
                                    szRet = szRet & "%CB%99"
                                Else
                                    If wch = " " Then
                                        szRet = szRet & "+"
                                    Else
                                        If wch = "=" Then
                                            szRet = szRet & "%3D"
                                        Else
                                            If wch = "`" Then
                                                szRet = szRet & "%60"
                                            Else
                                                If wch = "(" Then
                                                    szRet = szRet & "%28"
                                                Else
                                                    If wch = ")" Then
                                                        szRet = szRet & "%29"
                                                    Else
                                                        If wch = """" Then
                                                            szRet = szRet & "%22"
                                                        Else
                                                            If wch = "'" Then
                                                                szRet = szRet & "%27"
                                                            Else
                                                                If wch = "%" Then
                                                                    szRet = szRet & "%25"
                                                                Else
                                                                    '-------------------------------
                                                                    If wch = "$" Then
                                                                        szRet = szRet & "%24"
                                                                    Else
                                                                        If wch = "!" Then
                                                                            szRet = szRet & "%21"
                                                                        Else
                                                                            If wch = "#" Then
                                                                                szRet = szRet & "%23"
                                                                            Else
                                                                                If wch = "&" Then
                                                                                    szRet = szRet & "%26"
                                                                                Else
                                                                                    If wch = "." Or wch = "@" Or wch = "*" Then
                                                                                        szRet = szRet & wch
                                                                                    Else
                                                                                        nAsc = AscW(wch)
                                                                                        If nAsc < 0 Then nAsc = nAsc + 65536
                                                                                        If (nAsc And &HFF80) = 0 Then
                                                                                            szRet = szRet & wch
                                                                                        Else
                                                                                            If (nAsc And &HF000) = 0 Then
                                                                                                uch = "%" & Hex(((nAsc  2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                                                                                                szRet = szRet & uch
                                                                                            Else
                                                                                                uch = "%" & Hex((nAsc  2 ^ 12) Or &HE0) & "%" & _
                                                                                                Hex((nAsc  2 ^ 6) And &H3F Or &H80) & "%" & _
                                                                                                Hex(nAsc And &H3F Or &H80)
                                                                                                szRet = szRet & uch
                                                                                            End If
                                                                                        End If
                                                                                    End If
                                                                                End If
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next
    UTF8EncodeURI = szRet
End Function
Function Farmkey_cx() As String  '获取农场密钥
    Farmkey_cx = LCase(md5(Time_Cx & Mid(Fkey, (Time_Cx Mod 10) + 1, 20)))
End Function
Function addsxlb(uID As Long, rzl As Integer)  '加入刷新列表
    Dim tem1 As String
    Dim tem2 As String
    tem2 = uID
    If InStr(sxlb, "/" & tem2 & "//") > 0 Then  '刷新农场
       tem1 = Mid(sxlb, 1, InStr(sxlb, "/" & tem2 & "//") + Len(tem2) + 2)
       sxlb = tem1 & Time_C & Mid(sxlb, Len(tem1) + 11, Len(sxlb) - Len(tem1) - 9)
    Else
       sxlb = sxlb & "/" & tem2 & "//" & Time_C & "\" & rzl & "||,"
    End If
    
    Debug.Print "等待刷新：" & sxlb
End Function
Function shichaini(sc As Long)  '保存时差
    On Error Resume Next
    If Abs(inisc - sc) > 1 Then
        Debug.Print "更新时差：" & sc
        Dim temp As String
        Debug.Print "保存时差1：" & inisc & " " & sc
        temp = sc
        inisc = sc
        WritePrivateProfileString "Config", "shicha", temp, App.Path & "Config.ini"
    End If
End Function

						