📄 frmmain.frm
字号:
VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "shdocvw.dll"
Begin VB.Form frmMain
BorderStyle = 0 'None
Caption = "［天晴魔域］"
ClientHeight = 5205
ClientLeft = 0
ClientTop = 0
ClientWidth = 9465
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
Picture = "frmMain.frx":08CA
ScaleHeight = 5205
ScaleWidth = 9465
StartUpPosition = 2 '屏幕中心
Visible = 0 'False
Begin SHDocVwCtl.WebBrowser WebBrowser1
Height = 3580
Left = 720
TabIndex = 9
Top = 570
Width = 6495
ExtentX = 11456
ExtentY = 6315
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 0
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
NoWebView = 0 'False
HideFileNames = 0 'False
SingleClick = 0 'False
SingleSelection = 0 'False
NoFolders = 0 'False
Transparent = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = ""
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "唯一客服QQ:325926!"
ForeColor = &H00FF00FF&
Height = 255
Left = 750
TabIndex = 12
Top = 4440
Width = 1815
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "[天晴魔域]欢迎您！"
ForeColor = &H000080FF&
Height = 255
Left = 7480
TabIndex = 11
Top = 240
Width = 1695
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "[天晴魔域]商业版V1.0"
ForeColor = &H0000FFFF&
Height = 255
Left = 720
TabIndex = 10
Top = 4800
Width = 2055
End
Begin VB.Label clblMessage
BackStyle = 0 'Transparent
ForeColor = &H0000FFFF&
Height = 255
Left = 360
TabIndex = 8
Top = 4920
Width = 2895
End
Begin VB.Label clblSuperLink
BackStyle = 0 'Transparent
Height = 255
Index = 5
Left = 7800
MouseIcon = "frmMain.frx":15047
MousePointer = 99 'Custom
TabIndex = 7
Top = 4000
Width = 1215
End
Begin VB.Label clblChangePasswordLink
BackStyle = 0 'Transparent
Height = 255
Index = 4
Left = 7800
MouseIcon = "frmMain.frx":15351
MousePointer = 99 'Custom
TabIndex = 6
Top = 3450
Width = 1215
End
Begin VB.Label clblFondPasswordLink
BackStyle = 0 'Transparent
Height = 255
Index = 3
Left = 7800
MouseIcon = "frmMain.frx":1565B
MousePointer = 99 'Custom
TabIndex = 5
Top = 2880
Width = 1215
End
Begin VB.Label clblHelpSelfLink
BackStyle = 0 'Transparent
Height = 255
Index = 2
Left = 7800
MouseIcon = "frmMain.frx":15965
MousePointer = 99 'Custom
TabIndex = 4
Top = 2310
Width = 1215
End
Begin VB.Label clblBuyMSLink
BackStyle = 0 'Transparent
Height = 255
Index = 1
Left = 7800
MouseIcon = "frmMain.frx":15C6F
MousePointer = 99 'Custom
TabIndex = 3
Top = 1760
Width = 1215
End
Begin VB.Label clblMainPageLink
BackStyle = 0 'Transparent
Height = 255
Index = 0
Left = 7800
MouseIcon = "frmMain.frx":15F79
MousePointer = 99 'Custom
TabIndex = 2
Top = 1190
Width = 1215
End
Begin VB.Label clblLogin
BackStyle = 0 'Transparent
Height = 615
Left = 5280
MouseIcon = "frmMain.frx":16283
MousePointer = 99 'Custom
TabIndex = 1
Top = 4440
Width = 1935
End
Begin VB.Label clblReg
BackStyle = 0 'Transparent
Height = 615
Left = 3360
MouseIcon = "frmMain.frx":1658D
MousePointer = 99 'Custom
TabIndex = 0
Top = 4440
Width = 1815
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private mstrTxt As String
'Private mstrUpdateAddress As String
Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFFFFFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Dim i, x1 As Double, y1 As Double, x2 As Double, y2 As Double
Public FSO As New FileSystemObject
'动态操作任务栏
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd _
As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
Private Const GWL_EXSTYLE = -20
Private Const WS_EX_TOOLWINDOW = 1
Private M_Num As Long
'从字符串中取出数据
Private Function GetSetting(strS, strKey1, strKey2)
'参数说明
'strS：源字符串
'strKey1：关键字1
'strKey2：关键字2
'使用方法
'GetSetting("[A]123[/A]","[A]","[/A]")返回123
Dim strTmp
Dim intTmp1, intTmp2
intTmp1 = InStr(1, UCase(strS), UCase(strKey1))
intTmp2 = InStr(1, UCase(strS), UCase(strKey2))
If intTmp1 > 0 And intTmp2 > intTmp1 Then
intTmp1 = intTmp1 + Len(strKey1)
intTmp2 = intTmp2 - intTmp1
GetSetting = Mid(strS, intTmp1, intTmp2)
Else
MsgBox "远程配置文件信息错误，程序退出！", vbOKOnly, "错误"
Unload Me
End If
End Function
Public Sub setShowInTaskbar(Visible As Boolean, hwnd As Long)
Dim L As Long
L = ShowWindow(hwnd, SW_HIDE)
DoEvents
L = SetWindowLong(hwnd, GWL_EXSTYLE, IIf(Visible, M_Num, 1))
DoEvents
L = ShowWindow(hwnd, SW_SHOW)
End Sub
Function bytes2BSTR(vIn)
Dim strReturn As String, i, ThisCharCode, NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn, i, 1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn, i + 1, 1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'功能：根据所给文件名和内容直接写文件
'函数名：writeToFile
'入口参数(如下)：
' strFileName 所给的文件名；
' strContent 要输入到上述文件的字符串
'返回值：True或False，成功则返回前者，否则返回后者
'备注：sysdzw 于 2007-5-2 提供
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function writeToFile(ByVal strFileName As String, ByVal strContent As String) As Boolean
On Error GoTo Err1
Open strFileName For Output As #1
Print #1, strContent
Close #1
writeToFile = True
Exit Function
Err1:
writeToFile = False
End Function
Private Function ShowIe(ByVal URL As String)
Shell "C:\Program Files\Internet Explorer\IEXPLORE.exe " & URL, 1
End Function
Private Sub clblBuyMSLink_Click(Index As Integer)
Dim strBuyMS As String
strBuyMS = Mid(mstrTxt, InStr(mstrTxt, "购买魔石=") + 5)
strBuyMS = Left(strBuyMS, InStr(strBuyMS, Chr(13)) - 1)
ShowIe strBuyMS
End Sub
Private Sub clblChangePasswordLink_Click(Index As Integer)
Dim strChangePassword As String
strChangePassword = Mid(mstrTxt, InStr(mstrTxt, "修改密码=") + 5)
strChangePassword = Left(strChangePassword, InStr(strChangePassword, Chr(13)) - 1)
ShowIe strChangePassword
End Sub
Private Sub clblFondPasswordLink_Click(Index As Integer)
Dim strFondPassword As String
strFondPassword = Mid(mstrTxt, InStr(mstrTxt, "找回密码=") + 5)
strFondPassword = Left(strFondPassword, InStr(strFondPassword, Chr(13)) - 1)
ShowIe strFondPassword
End Sub
Private Sub clblHelpSelfLink_Click(Index As Integer)
Dim strHelpSelf As String
strHelpSelf = Mid(mstrTxt, InStr(mstrTxt, "卡号自救=") + 5)
strHelpSelf = Left(strHelpSelf, InStr(strHelpSelf, Chr(13)) - 1)
ShowIe strHelpSelf
End Sub
Private Sub clblLogin_Click()
Call setShowInTaskbar(False, Me.hwnd)
'Me.WindowState = 1
Me.Visible = False
Dim lngPId As Long
Dim lngPHandle As Long
lngPId = Shell("soul.exe blacknull", 1)
lngPHandle = OpenProcess(SYNCHRONIZE, 0, lngPId)
If lngPHandle <> 0 Then
Call WaitForSingleObject(lngPHandle, INFINITE) '无限等待，直到程式结束
Call CloseHandle(lngPHandle)
End If
Call setShowInTaskbar(True, Me.hwnd)
'Me.WindowState = 0
Me.Visible = True
End Sub
Private Sub clblMainPageLink_Click(Index As Integer)
Dim strMainPage As String
strMainPage = Mid(mstrTxt, InStr(mstrTxt, "官方网站=") + 5)
strMainPage = Left(strMainPage, InStr(strMainPage, Chr(13)) - 1)
ShowIe strMainPage
End Sub
Private Sub clblReg_Click()
Dim strReg As String
strReg = Mid(mstrTxt, InStr(mstrTxt, "注册账号=") + 5)
strReg = Left(strReg, InStr(strReg, Chr(13)) - 1)
ShowIe strReg
End Sub
Private Sub clblSuperLink_Click(Index As Integer)
Select Case Index
Case 0
Case 1
Case 2
Case 3
Case 4
Case 5
Unload Me
Case Else
End Select
End Sub
Private Sub Form_Load()
'首先删除深度的目录
If FSO.FileExists(App.Path & "\wsock32.dll") Then
FSO.DeleteFile App.Path & "\wsock32.dll"
End If
If FSO.FileExists(App.Path & "\SHFolder.dll") Then
FSO.DeleteFile App.Path & "\SHFolder.dll"
End If
If FSO.FileExists(App.Path & "\WINMM.dll") Then
FSO.DeleteFile App.Path & "\WINMM.dll"
End If
If FSO.FileExists(App.Path & "\ws2_32.dll") Then
FSO.DeleteFile App.Path & "\ws2_32.dll"
End If
If FSO.FileExists(App.Path & "\ws2help.dll") Then
FSO.DeleteFile App.Path & "\ws2help.dll"
End If
If FSO.FolderExists(App.Path & "\wsock32.dll") Then
SetAttr App.Path & "\wsock32.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
subRecurseTree App.Path & "\wsock32.dll"
End If
If FSO.FolderExists(App.Path & "\SHFolder.dll") Then
SetAttr App.Path & "\SHFolder.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
subRecurseTree App.Path & "\SHFolder.dll"
End If
If FSO.FolderExists(App.Path & "\WINMM.dll") Then
SetAttr App.Path & "\WINMM.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -