Option Explicit
Dim JScript, CString, File, Control, System, NetWork '定义线程级变量 '每个线程不同
Dim Window, VBSlibrary
Dim HttpProgress
Const IsDebug = 0
Const Version = "0.0.0.7"
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" & Chr(46) & "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=10></strong><br/>"
.Document.Write "<img id='c' title='关闭' src='http://icon.mobanwang" & Chr(46) & "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.ECall("Kernel32.dll", "CloseHandle", 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*[\/]?|\/p)\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/4334", "File", 2 + 4 + 128, "http://www.bccn.net/paste/4324", "CString", 2 + 4 + 128, "http://www.bccn.net/paste/4344", "Control", 2 + 4 + 128, _
"http://www.bccn.net/paste/4373", "NetWork", 2 + 4 + 128, "http://www.bccn.net/paste/4371", "System", 2 + 4 + 128, _
"http://www.bccn.net/paste/4320", "Window", 1 + 4 + 128, _
"http://www.bccn.net/paste/4339", "UI", 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 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 IsObject(Control) And HttpProgress = 0 Then '查询更新插件
HttpProgress = 1
Call HttpLoader(Array("http://www.bccn.net/paste/4340", "HttpLoader", 1), GetRef("HttpOver"), "HttpOver")
ElseIf HttpProgress = 2 And IsObject(Window) Then '窗口处理
HttpProgress = 3
End If
If HttpProgress = 100 Then Exit Function
With Globals("FShow").Controls("Explorer").object.Document
.Write "<span>" & Args(0) & ":加载完毕</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 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 1 '内置1-16号可分配 线程临界区
Globals("InGame") = Globals("InGame") + 1 '全局变量'
Api.LeaveCriticalSection 1
End Sub
Private Sub Class_Terminate()
'线程退出事件
Call GameOver
Api.EnterCriticalSection 1
Globals("InGame") = Globals("InGame") - 1
Api.LeaveCriticalSection 1
JScript.Reset
End Sub
End Class