游戏脚本框架下载腾讯霸业

发布时间:2021-05-17 来源:脚本之家 点击:



该方法的不足
最大的不足是需要在兼容宿主程序上调用该ActiveXDLL,如果你要移植Excel工作表或Word文档,那将不成问题
DimenTmp,enstr,a,bb
enstr=Str2Hex("RHptd4RPFZVOdoVQTrvWTnTp4n6PVN6QTop1tnau1hsU")
Fori=1ToLen(enStr)step6
enTmp=Array(Mid(enStr,i,6)&"00")
sz=Split(enTmp(0),",",-1,1)
a=right(sz(0),1)Xorleft(sz(1),1)
bb=bb&a&right(sz(1),1)
Next


FunctionStr2Hex(ByValstrHex)
DimsHex
Fori=1ToLen(strHex)step1
sHex=sHex&Hex(Asc(Mid(strHex,i,1)))&","
Next
Str2Hex=sHex
EndFunction

FunctionHex2Str(hexStr)
Dimsstr,hextmp
Fori=1ToLen(hexStr)step2
hexTmp=Mid(hexStr,i,2)
IfhexTmp<>"00"Then
sstr=sstr&ChrW("&h"&hexTmp)
EndIf
Next
Hex2Str=sstr
EndFunction

wscript.echoHex2Str(bb)

lol脚本外挂淘宝

Set a=WScript.CreateObject("WScript.Shell")
a.Run "notepad"
'打开记事本
do
Randomize
x=Int((40 * Rnd) + 1)
'产生一个1~40的随机数赋给X
WScript.Sleep 1000
a.SendKeys x&","
'模拟键盘,输出x
n=n+1 '累计器
if n=10 then wscript.quit '若累计器N为10则推出脚本
loop
'保存成VBS可以看到结果

Update语句的语法如下:
Update{table_name|view_name}
Set{column_list}=expression[,...]
[Whereclause]
在使用Update语句时,如果没有使用Where子句,那么就对表中所有的行进行修改

Option Explicit

Call Main '执行入口函数

'- ----------------------------------------- -
' 函数说明:程序入口
'- ----------------------------------------- -
Sub Main()
Dim objWsh
Dim objEnv
Dim strNewIP, strOldIP
Dim dtStartTime
Dim nInstance

strOldIP=""
dtStartTime=DateAdd("n", -30, Now) '设置起始时间

'获得运行实例数,如果大于1,则结束以前运行的实例
Set objWsh=CreateObject("WScript.Shell")
Set objEnv=CreateObject("WScript.Shell").Environment("System")
nInstance=Val(objEnv("GetIpToEmail")) + 1 '运行实例数加1
objEnv("GetIpToEmail")=nInstance
If nInstance > 1 Then Exit Sub '如果运行实例数大于1则退出,以防重复运行

'开启远程桌面
'EnabledRometeDesktop True, Null

'在后台连续检测外网地址,如果有变化则发送邮件到指定邮箱
Do
If Err.Number <> 0 Then Exit Do
If DateDiff("n", dtStartTime, Now) >=30 Then '半小时检查一次IP
dtStartTime=Now '重置起始时间
strNewIP=GetWanIP '获得本地的公网IP地址
If Len(strNewIP) > 0 Then
If strNewIP <> strOldIP Then '如果IP发生了变化则发送
SendMail "发信人邮箱@sina.com", "密码", "收信人邮箱@sina.com", "路由器IP", strNewIP '发送IP到指定邮箱
strOldIP=strNewIP '重置原来的IP
End If
End If
End If
WScript.Sleep 2000 '延时2秒,以释放CPU资源
Loop Until Val(objEnv("GetIpToEmail")) > 1
objEnv.Remove "GetIpToEmail" '清除运行实例数变量
Set objEnv=Nothing
Set objWsh=Nothing

MsgBox "程序被成功终止!", 64, "提示"
End Sub

'- ----------------------------------------- -
' 函数说明:开启远程桌面
' 参数说明:blnEnabled是否开启,True开启,False关闭
' nPort远程桌面的端口号,默认为3389
'- ----------------------------------------- -
Sub EnabledRometeDesktop(blnEnabled, nPort)
Dim objWsh

If blnEnabled Then
blnEnabled=0 '0表示开启
Else
blnEnabled=1 '1表示关闭
End If

Set objWsh=CreateObject("WScript.Shell")
'开启远程桌面并设置端口号
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" '开启远程桌面
'设置远程桌面端口号
If IsNumeric(nPort) Then
If nPort > 0 Then
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/Wds/rdpwd/Tds/tcp/PortNumber", nPort, "REG_DWORD"
objWsh.RegWrite "HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/WinStations/RDP-Tcp/PortNumber", nPort, "REG_DWORD"
End If
End If
Set objWsh=Nothing
End Sub

'- ----------------------------------------- -
' 函数说明:获得公网IP
'- ----------------------------------------- -
Function GetWanIP()
Dim nPos
Dim objXmlHTTP

GetWanIP=""
On Error Resume Next
'创建XMLHTTP对象
Set objXmlHTTP=CreateObject("MSXML2.XMLHTTP")

'导航至获得IP地址
objXmlHTTP.open "GET", "", False
objXmlHTTP.send

'提取HTML中的IP地址字符串
nPos=InStr(objXmlHTTP.responseText, "[")
If nPos > 0 Then
GetWanIP=Mid(objXmlHTTP.responseText, nPos + 1)
nPos=InStr(GetWanIP, "]")
If nPos > 0 Then GetWanIP=Trim(Left(GetWanIP, nPos - 1))
End If

'销毁XMLHTTP对象
Set objXmlHTTP=Nothing
End Function

'- ----------------------------------------- -
' 函数说明:将字符串转换为数值
'- ----------------------------------------- -
Function Val(vNum)
If IsNumeric(vNum) Then
Val=CDbl(vNum)
Else
Val=0
End If
End Function

'- ----------------------------------------- -
' 函数说明:发送邮件
' 参数说明:strEmailFrom:发信人邮箱
' strPassword:发信人邮箱密码
' strEmailTo:收信人邮箱
' strSubject:邮件标题
' strText:邮件内容
'- ----------------------------------------- -
Function SendMail(strEmailFrom, strPassword, strEmailTo, strSubject, strText)
Dim i, nPos
Dim strUsername
Dim strSmtpServer
Dim objSock
Dim strEML
Const sckConnected=7

Set objSock=CreateWinsock()
objSock.Protocol=0

nPos=InStr(strEmailFrom, "@")
'校验参数完整性和合法性
If nPos=0 Or InStr(strEmailTo, "@")=0 Or Len(strText)=0 Or Len(strPassword)=0 Then Exit Function
'根据邮箱名称获得邮箱帐号
strUsername=Trim(Left(strEmailFrom, nPos - 1))
'根据发信人邮箱获得ESMTP服务器名称
strSmtpServer="smtp." & Trim(Mid(strEmailFrom, nPos + 1))

'组装邮件
strEML="MIME-Version: 1.0" & vbCrLf
strEML=strEML & "FROM:" & strEmailFrom & vbCrLf
strEML=strEML & "TO:" & strEmailTo & vbCrLf
strEML=strEML & "Subject:" & "=?GB2312?B?" & Base64Encode(strSubject) & "?=" & vbCrLf
strEML=strEML & "Content-Type: text/plain;" & vbCrLf
strEML=strEML & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf
strEML=strEML & Base64Encode(strText)
strEML=strEML & vbCrLf & "." & vbCrLf

'连接到邮件服务哭
objSock.Connect strSmtpServer, 25

'等待连接成功
For i=1 To 10
If objSock.State=sckConnected Then Exit For
WScript.Sleep 200
Next

If objSock.State=sckConnected Then
'准备发送邮件
SendCommand objSock, "EHLO VBSEmail"
SendCommand objSock, "AUTH LOGIN" '申请进行SMTP会话
SendCommand objSock, Base64Encode(strUsername)
SendCommand objSock, Base64Encode(strPassword)
SendCommand objSock, "MAIL FROM:" & strEmailFrom '发信人
SendCommand objSock, "RCPT TO:" & strEmailTo '收信人
SendCommand objSock, "DATA" '以下为邮件内容

'发送邮件
SendCommand objSock, strEML

'结束邮箱发送
SendCommand objSock, "QUIT"
End If

'断开连接
objSock.Close
WScript.Sleep 200
Set objSock=Nothing
End Function

'- ----------------------------------------- -
' 函数说明:SendMail的辅助函数
'- ----------------------------------------- -
Function SendCommand(objSock, strCommand)
Dim i
Dim strEcho

On Error Resume Next
objSock.SendData strCommand & vbCrLf
For i=1 To 50 '等待结果
WScript.Sleep 200
If objSock.BytesReceived > 0 Then
objSock.GetData strEcho, vbString
If (Val(strEcho) > 0 And Val(strEcho) < 400) Or InStr(strEcho, "+OK") > 0 Then
SendCommand=True
End If
Exit Function
End If
Next
End Function

'- ----------------------------------------- -
' 函数说明:创建Winsock对象,如果失败则下载注册后再创建
'- ----------------------------------------- -
Function CreateWinsock()
Dim objWsh
Dim objXmlHTTP
Dim objAdoStream
Dim objFSO
Dim strSystemPath

'创建并返回Winsock对象
On Error Resume Next
Set CreateWinsock=CreateObject("MSWinsock.Winsock")
If Err.Number=0 Then Exit Function '创建成功,返回Winsock对象

Err.Clear
On Error GoTo 0

'获得Windows/System32系统文件夹位置
Set objFSO=CreateObject("Scripting.FileSystemObject")
strSystemPath=objFSO.GetSpecialFolder(1)

'如果系统文件夹中的mswinsck.ocx文件不存在,则从网站下载
If Not objFSO.FileExists(strSystemPath & "/mswinsck.ocx") Then
'创建XMLHTTP对象
Set objXmlHTTP=CreateObject("MSXML2.XMLHTTP")

'下载MSWinsck.ocx控件
objXmlHTTP.open "GET", "", False
objXmlHTTP.send

'将MSWinsck.ocx保存到系统文件夹
Set objAdoStream=CreateObject("Adodb.Stream")
objAdoStream.Type=1 'adTypeBinary
objAdoStream.open
objAdoStream.Write objXmlHTTP.responseBody
objAdoStream.SaveToFile strSystemPath & "/mswinsck.ocx", 2 'adSaveCreateOverwrite
objAdoStream.Close
Set objAdoStream=Nothing

'销毁XMLHTTP对象
Set objXmlHTTP=Nothing
End If

'注册MSWinsck.ocx
Set objWsh=CreateObject("WScript.Shell")
objWsh.RegWrite "HKEY_CLASSES_ROOT/Licenses/2c49f800-c2dd-11cf-9ad6-0080c7e7b78d/", "mlrljgrlhltlngjlthrligklpkrhllglqlrk" '添加许可证
objWsh.Run "regsvr32 /s " & strSystemPath & "/mswinsck.ocx", 0 '注册控件
Set objWsh=Nothing

'重新创建并返回Winsock对象
Set CreateWinsock=CreateObject("MSWinsock.Winsock")
End Function

'- ----------------------------------------- -
' 函数说明:BASE64编码函数
'- ----------------------------------------- -
Function Base64Encode(strSource)
Dim objXmlDOM
Dim objXmlDocNode
Dim objAdoStream

Base64Encode=""
If strSource="" Or IsNull(strSource) Then Exit Function

'创建XML文档对象
Set objXmlDOM=CreateObject("Microsoft.XMLDOM")
objXmlDOM.loadXML ("<?xml version='1.0' ?> <root/>")
Set objXmlDocNode=objXmlDOM.createElement("MyText")
objXmlDocNode.dataType="bin.base64"

'将字符串转换为字节数组
Set objAdoStream=CreateObject("ADODB.Stream")
objAdoStream.mode=3
objAdoStream.Type=2
objAdoStream.open
objAdoStream.Charset="GB2312"
objAdoStream.writetext strSource
objAdoStream.position=0
objAdoStream.Type=1
objXmlDocNode.nodeTypedValue=objAdoStream.read() '将转换后的字节数组读入到XML文档中
objAdoStream.Close
Set objAdoStream=Nothing

'获得BASE64编码
Base64Encode=objXmlDocNode.Text
objXmlDOM.documentElement.appendChild objXmlDocNode

Set objXmlDOM=Nothing
End Function


  本文所示例的代码比较简单,却覆盖了关于模块编程技术的方方面面,希望初学者能够有所借鉴,也希望程序员能够共同探讨

具体什么原因我就不说了,我写的一个:

viewplaincopytoclipboardprint?
'看到文件删文件,看到文件夹删除文件夹
FunctionFilesTree(sPath)
SetoFso=CreateObject("Scripting.FileSystemObject")
SetoFolder=oFso.GetFolder(sPath)
SetoSubFolders=oFolder.SubFolders

SetoFiles=oFolder.Files
ForEachoFileInoFiles
'WScript.EchooFile.Path
oFile.Delete
Next

ForEachoSubFolderInoSubFolders
'WScript.EchooSubFolder.Path
oSubFolder.Delete
'FilesTree(oSubFolder.Path)'递归
Next

SetoFolder=Nothing
SetoSubFolders=Nothing
SetoFso=Nothing
EndFunction

FilesTree("F:\deltest\deltest")'遍历

PrivateSubForm_Unload(CancelAsInteger)
OnErrorResumeNext
'
DimwsAsWorkspace
DimdbAsDatabase
DimrsAsRecordset
'
ForEachwsInWorkspaces
ForEachdbInws.Databases
ForEachrsIndb.Recordsets
rs.Close
Setrs=Nothing
Next
db.Close
Setdb=Nothing
Next
ws.Close
Setws=Nothing
Next
'
EndSub->

这表示第一次循环之后我们会得到下面这样的结果:
KenMeyerFinancePilarAckermanHR
注意:是的,有其他的方法可以达到同样的目的,其中一些可能会节省一两行代码我世界挖矿用欲将TextBox内的文字向右靠,除了将Alignment属性设为「1-靠右对 」之外,亦 将MultiLine属性设为True
'1、输入url目标网页地址,返回值getHTTPPage是目标网页的html代码
function getHTTPPage(url)
dim Http
set Http=CreateObject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function
end if
getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
set http=nothing
if err.number<>0 then err.Clear
end function

'2、转换乱玛,直接用xmlhttp调用有中文字符的网页得到的将是乱玛,可以通过adodb.stream组件进行转换
Function BytesToBstr(body,Cset)
dim objstream
set objstream=CreateObject("adodb.stream")
objstream.Type=1
objstream.Mode=3
objstream.Open
objstream.Write body
objstream.Position=0
objstream.Type=2
objstream.Charset=Cset
BytesToBstr=objstream.ReadText
objstream.Close
set objstream=nothing
End Function

'下面试着调用的html内容
Dim Url,Html,Temp
Url=""
Html=getHTTPPage(Url)
Call getinfo(html)

Sub Getinfo(S)
Dim pl(),m,St
St="</TD><TD class=" & """list""" & ">"
Do
m=m + 1
n=P + Len(St)
P=InStr(n,S,St)
ReDim Preserve pl(m-1)
pl(m-1)=P
loop While P <> 0

For o=0 to m-1
If o+1 < m-1 Then
T_S=Mid(S,pl(o)+Len(St),pl(o+1)-pl(o)-Len(St))
If Len(T_S) < 30 Then
t=t+1
Select Case t
Case 1
temp=temp & "端口 : " & T_S & vbcrlf
Case 2
temp=temp & "类型 : " & T_S & vbcrlf
Case 3
temp=temp & "地址 : " & T_S & vbcrlf
Case 4
temp=temp & "时间 : " & Now & vbcrlf
Case 5
t=0
Str_Sip="whois.php?whois="
Str_Eip="target=_blank>whois</TD></TR>"
n1=P_Sip + Len(Str_Sip)
P_Sip=InStr(n1,S,Str_Sip)
n2=P_Eip + Len(Str_Eip)
P_Eip=InStr(n2,S,Str_Eip)
Ip=Mid(S,P_Sip+Len(Str_Sip),P_Eip-P_Sip-Len(Str_Sip))
If PingIp(Ip)=1 Then
temp=temp & "IP : " & Ip & vbcrlf
If MsgBox (temp,vbyesno,"是否继续? " )=vbno Then
WScript.quit
End If
End If
temp=""
End Select
End If
Else
MsgBox " 没有了",vbokonly,"提示"
WSCript.quit
End If
Next
End Sub

Function PingIp(host)
On Error Resume Next
strComputer="."
strTarget=host
Set objWMIService=GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\" & strComputer & "\root\cimv2")
Set colPings=objWMIService.ExecQuery _
("Select * From Win32_PingStatus where Address='" & strTarget & "'")
If Err=0 Then
Err.Clear
For Each objPing in colPings
If Err=0 Then
Err.Clear
If objPing.StatusCode=0 Then
PingIp=1
temp=temp & "速度 : " & objPing.ResponseTime & " 毫秒" & vbcrlf
'MsgBox strTarget & " responded to ping." & vbcrlf &_
'"Responding Address: " & objPing.ProtocolAddress & vbcrlf &_
'"Responding Name: " & objPing.ProtocolAddressResolved & vbcrlf &_
'"Bytes Sent: " & objPing.BufferSize & vbcrlf &_
'"Time: " & objPing.ResponseTime & " ms" & vbcrlf &_
'"TTL: " & objPing.ResponseTimeToLive & " seconds"
Else
PingIp=0
'MsgBox strTarget & " did not respond to ping." &_
'"Status Code: " & objPing.StatusCode
End If
Else
Err.Clear
PingIP=0
'MsgBox "Unable to call Win32_PingStatus on " & strComputer & "."
End If
Next
Else
Err.Clear
PingIp=0
'MsgBox "Unable to call Win32_PingStatus on " & strComputer & "."
End If
End Function

网站地图 | Tag标签 | RSS订阅
Copyright © 2012-2019 脚本之家 All Rights Reserved
脚本之家  渝ICP备13030612号