BP

作者在 2021-06-17 22:20:45 发布以下内容
Option Explicit
Dim JScript, CString  '定义线程级变量       '每个线程不同
Dim Window, File
Dim HttpProgress
Const IsDebug = 0
Const Version = "0.0.0.4"
Sub Main()
    If Globals("App").PrevInstance Then
        Dim ws, WMI, Process
        Set ws = CreateObject("wscript.shell")
        ws.SendKeys "{HOME}"
        Set WMI = GetObject("WinMgmts:")
        For Each Process In WMI.ExecQuery("select * from win32_process where name='" & Globals("App").EXEName & ".exe'")
            Call ws.AppActivate(Process.ProcessId)
        Next
        Call Api.ECall("kernel32", "ExitProcess", 0)
    End If
    Set Globals("FShow") = Api.NewForm()
    With Globals("FShow")
        .Appearance = 0
        .Caption = "正在连接服务器"
        Call Api.ECall("user32.dll", "SetWindowLongA", .hWnd, -16, &H6000000)
        .Move 0, 0, 0, 0
        .Height = (250 - .ScaleHeight) * Globals("Screen").TwipsPerPixelY + .Height
        .Width = (400 - .ScaleWidth) * Globals("Screen").TwipsPerPixelX + .Width
        .Move (Globals("Screen").Width - .Width) \ 2, (Globals("Screen").Height - .Height) \ 2
        With .Controls.Add("Shell.Explorer", "Explorer")
            .Move -2, -2, 404, 254
            With .object
                .Navigate "about:blank"
                .Document.Write "<style>body {margin:0;padding:10px;overflow:hidden;cursor:default;background:url('http://ossweb-img.qq.com/upload/gameact/iShow/82/1292421886_-1719592020_8934_sProdImgNo_2.jpg') no-repeat center}" & _
                "strong {font-size:15px;color:#F0F}span {font-size:15px;color:#0CF}font {font-size:15px;color:#06F}em {font-size:15px;color:#03F}</style>"
                .Document.Write "<strong id='t' value=0 list=8></strong><br/>"
                .Document.Write "<img id='c' title='关闭' src='http://icon.mobanwang.com/UploadFiles_8971/200805/20080528160824702.png' style='top:5px;right:5px;width:40px;height:40px;position:absolute;cursor:pointer;'>"
                With .Document.All
                    .c.onclick = GetRef("Close")
                    .t.innerHTML = "服务器正在加载中(" & .t.Value & "/" & .t.List & ")...."
                End With
            End With
            .Visible = True
        End With
        .Show
        Call Api.CreateThread("Show " & .hWnd)
    End With
End Sub
Sub OnLoad()    '加载完Main'
    Set JScript = Api.NewScript(, "JScript")
    JScript.AddCode "function htmlFormat(HTML){" & vbCrLf & _
        "HTML = HTML.replace(/<br\s*[\/]?>/gi, '\n')" & vbCrLf & _
        "HTML = HTML.replace(/<(style|script|iframe)[^>]*?>[\s\S]*?<\/\1\s*>/gi, '')" & vbCrLf & _
        "HTML = HTML.replace(/<[^>]+?>/g, '')" & vbCrLf & _
        "var arrEntities = { 'lt': '<', 'gt': '>', 'nbsp': ' ', 'amp': '&', 'quot': '""' };" & vbCrLf & _
        "HTML = HTML.replace(/&(lt|gt|nbsp|amp|quot);/ig, function ($0, $1) { return arrEntities[$1]; });" & vbCrLf & _
        "return HTML.replace(/&#(\d+);/g, function ($0, $1) { return String.fromCharCode($1); })" & vbCrLf & _
    "}"
    HttpProgress = 0
    Call HttpLoader(Array("http://www.bccn.net/paste/4320", "Window", 1+4+128,_
        "http://www.bccn.net/paste/4334", "File", 2+4+128, "http://www.bccn.net/paste/4324", "CString", 2+4+128, _
        "http://www.bccn.net/paste/4330", "UI", 128, "http://www.bccn.net/paste/4344", "Control", 128), _
        GetRef("HttpOver"),"HttpOver")
End Sub
Sub LoadOver()
    Dim UI
    If IsDebug Then
        Api.Import "UI_Class.vbs", 1
    Else
        Api.Import Globals("UI_Class")
        Globals.Remove "UI_Class"
    End If
    Set UI = New UI_Class '支持任意类型的全局变量(所有线程一致)
    Set Globals("Form") = UI.Form
    Api.iDoEvents
    UI.Form_LoadOver
    Api.UnloadForm Globals("FShow")
    Set Globals("FShow") = Nothing
End Sub
Sub IsLoadOver(iClass)
    If HttpProgress = 100 Then Exit Sub
    With Globals("FShow").Controls("Explorer").object.Document
        .Write "<span>" & iClass & ":加载完毕</span><br/>"
        With .All.t
            .Value = .Value + 1
            .innerHTML = "服务器正在加载中(" & .Value & "/" & .List & ")...."
            If .Value = Int(.List) Then
                HttpProgress = 100
                Call LoadOver
            End If
        End With
    End With
End Sub
Sub Close()
    Api.UnloadForm Globals("FShow")
End Sub
Sub HttpLoader(v, o, func)
    Dim i
    For i = 0 To UBound(v) Step 3
        Api.NewHttp().GetHttpEx v(i), Array(o, func, Array(v(i + 1), v(i + 2)))
    Next
End Sub
Function HttpOver(xmlhttp, Args)
    If HttpClass(xmlhttp, Args) Then
        If IsObject(File) And IsObject(CString) And HttpProgress = 0 Then '查询更新插件
            HttpProgress = 1
            Call HttpLoader(Array("http://www.bccn.net/paste/4335", "HttpLoader", 1), GetRef("HttpOver"), "HttpOver")
        ElseIf HttpProgress = 2 And IsObject(Window) Then '窗口处理
            HttpProgress = 3
        End If
        Call IsLoadOver(Args(0))
    End If
End Function
Function HttpClass(xmlhttp, Args)   '异步加载'
    HttpClass = xmlhttp.ReadyState = 4
    If HttpClass Then
        'If xmlhttp.status = 200 Then
        Dim Text
        If IsNumeric(Args(1)) = False Then
            If Len(File.FolderExists(Args(1), 1 + 2)) Then File.WriteFlie Args(1), xmlhttp.responseBody, True
            ' If InStr(Args(0),".") Then Call Api.ECall(Args(1), "DllRegisterServer")
        Else
            Text = GetClass(xmlhttp.responseText)
            If Args(1) And 1 Then   'VBS
                If Args(1) And 8 Then ExeCute Text Else Api.Import Text
                If Args(1) And 4 Then
                    ExeCute "Set " & Args(0) & " = New " & Args(0) & "_Class"
                ElseIf Args(1) And 16 Then
                    ExeCute Args(0)
                End If
            ElseIf Args(1) And 2 Then   'JS
                If Args(1) And 8 Then JScript.ExecuteStatement Text Else JScript.AddCode Text
                If Args(1) And 4 Then
                    ExeCute "Set " & Args(0) & " = JScript.Eval(""new " & Args(0) & "_Class"")"
                ElseIf Args(1) And 16 Then
                    ExeCute Args(0)
                End If
            End If
            If Args(1) And 128 Then Globals(Args(0) & "_Class") = Text
        End If
    End If
End Function
Function GetClass(S)
    Dim html, i, t
    t = "<pre><span></span>"
    i = InStr(S, t) + Len(t)
    S = Mid(S, i, InStr(i, S, "</pre></div>") - i)
    ' Set html = CreateObject("htmlfile")
    ' html.designMode = "on"
    ' html.Write Replace(S, Chr(10), "<br/>")
    ' GetClass = html.body.innerText
    GetClass = JScript.run("htmlFormat", S) 
End Function
Sub Show(hWnd)
    Dim style, i
    Const LWA_ALPHA = &H2
    Const WS_EX_LAYERED = &H80000
    Const WS_EX_TRANSPARENT = &H20
    style = Api.ECall("user32.dll", "GetWindowLongA", hWnd, -20)
    ' Call Api.ECall("user32", "SetWindowPos", hWnd, -1, 0, 0, 0, 0, &H3)
    Call Api.ECall("user32.dll", "SetWindowLongA", hWnd, -20, style Or WS_EX_LAYERED Or WS_EX_TRANSPARENT)
    For i = 0 To 255
        If Api.ECall("user32.dll", "SetLayeredWindowAttributes", hWnd, 0, i, LWA_ALPHA) = 0 Then Exit Sub
        Api.Delay 5
    Next
    Call Api.ECall("user32.dll", "SetWindowLongA", hWnd, -20, style)
End Sub


Function SafeGet(Str, Num)   'SafeSet("Form.Caption" ,1)
    Api.EnterCriticalSection Num
    SafeGet = Eval(Str)
    Api.LeaveCriticalSection Num
End Function
Sub SafeSet(Str, Num)    'SafeSet("Form.Caption=Form.Caption+1" ,1)
    Api.EnterCriticalSection Num
    ExeCute Str
    Api.LeaveCriticalSection Num
End Sub
Sub ThreadStart(Arys)
    Dim GameApp
    Api.EnterCriticalSection 1
    Api.Import Globals("Window_Class")
    Set JScript = Api.NewScript(Globals("File_Class"), "JScript")
    Api.LeaveCriticalSection 1
    Set Window = New Window_Class
    Set File = JScript.Eval("new File_Class")
    Set GameApp = New Game_Class
    Call GameApp.GameStart(Arys)
End Sub
Class Game_Class
    Public Sub GameStart(Arys)
        Dim i, QQSpeed
        If IsDebug Then
            Api.Import "QQSpeed_Class.vbs", 1
        Else
            Api.EnterCriticalSection 1
            Api.Import Globals("QQSpeed_Class")
            Api.LeaveCriticalSection 1
        End If
        Set QQSpeed = New QQSpeed_Class
        QQSpeed.Start Arys
    End Sub
    Private Sub GameOver()
    End Sub
    Private Sub Class_Initialize()
        '线程启动事件     'Api.ResetCriticalSection X  可以强制还原所有 或者X号线程锁
        Api.EnterCriticalSection 16     '内置1-16号可分配 线程临界区
        Globals("InGame") = Globals("InGame") + 1   '全局变量'
        Api.LeaveCriticalSection 16
    End Sub
    Private Sub Class_Terminate()
        '线程退出事件
        Call GameOver
        Api.EnterCriticalSection 16
        Globals("InGame") = Globals("InGame") - 1
        Api.LeaveCriticalSection 16
        JScript.Reset
    End Sub
End Class  
QQ飞车 | 阅读 1496 次
文章评论,共0条
游客请输入验证码
浏览2049次
最新评论