'文件名SourceDB.ini文件
PrivateDeclareFunctionGetPrivateProfileStringLib"kernel32"Alias
"GetPrivateProfileStringA"(ByVallpApplicationNameAsString,ByVallpKeyNameAsAny,ByVal
lpDefaultAsString,ByVallpReturnedStringAsString,ByValnSizeAsLong,ByVal
lpFileNameAsString)AsLong
PrivateDeclareFunctionWritePrivateProfileStringLib"kernel32"Alias
"WritePrivateProfileStringA"(ByVallpApplicationNameAsString,ByVallpKeyNameAsAny,ByVal
lpStringAsAny,ByVallpFileNameAsString)AsLong
'以下两个函数,读/写ini文件,固定节点setting,in_key为写入/读取的主键
'仅仅针对是非值
'Y：yes,N：no,E：error
PublicFunctionGetIniTF(ByValIn_KeyAsString)AsBoolean
OnErrorGoToGetIniTFErr
GetIniTF=True
DimGetStrAsString
GetStr=VBA.String(128,0)
GetPrivateProfileString"Setting",In_Key,"",GetStr,256,App.Path&"\SourceDB.ini"
GetStr=VBA.Replace(GetStr,VBA.Chr(0),"")
IfGetStr="1"Then
GetIniTF=True
GetStr=""
Else
GoToGetIniTFErr
EndIf
ExitFunction
GetIniTFErr:
Err.Clear
GetIniTF=False
GetStr=""
EndFunction
PublicFunctionWriteIniTF(ByValIn_KeyAsString,ByValIn_DataAsBoolean)AsBoolean
OnErrorGoToWriteIniTFErr
WriteIniTF=True
IfIn_Data=TrueThen
WritePrivateProfileString"Setting",In_Key,"1",App.Path&"\SourceDB.ini"
Else
WritePrivateProfileString"Setting",In_Key,"0",App.Path&"\SourceDB.ini"
EndIf
ExitFunction
WriteIniTFErr:
Err.Clear
WriteIniTF=False
EndFunction
'以下两个函数,读/写ini文件,不固定节点,in_key为写入/读取的主键
'针对字符串值
'空值表示出错
PublicFunctionGetIniStr(ByValAppNameAsString,ByValIn_KeyAsString)AsString
OnErrorGoToGetIniStrErr
IfVBA.Trim(In_Key)=""Then
GoToGetIniStrErr
EndIf
DimGetStrAsString
GetStr=VBA.String(128,0)
GetPrivateProfileStringAppName,In_Key,"",GetStr,256,App.Path&"\SourceDB.ini"
GetStr=VBA.Replace(GetStr,VBA.Chr(0),"")
IfGetStr=""Then
GoToGetIniStrErr
Else
GetIniStr=GetStr
GetStr=""
EndIf
ExitFunction
GetIniStrErr:
Err.Clear
GetIniStr=""
GetStr=""
EndFunction
PublicFunctionWriteIniStr(ByValAppNameAsString,ByValIn_KeyAsString,ByValIn_DataAsString)AsBoolean
OnErrorGoToWriteIniStrErr
WriteIniStr=True
IfVBA.Trim(In_Data)=""OrVBA.Trim(In_Key)=""OrVBA.Trim(AppName)=""Then
GoToWriteIniStrErr
Else
WritePrivateProfileStringAppName,In_Key,In_Data,App.Path&"\SourceDB.ini"
EndIf
ExitFunction
WriteIniStrErr:
Err.Clear
WriteIniStr=False
EndFunction
->dimAsoR,FlashFileName
SetArgObj=WScript.Arguments
dimPositionStart,OKed,Tag,EndSize
PositionStart=920000'flash4的播放器的大致字节数
EndSize=8'exe文件结尾字节数,其它版本可以设置为0
FlashFileName=ArgObj(0)'传递路径
setAsoR=CreateObject("Adodb.Stream")
AsoR.Mode=3
AsoR.Type=1
AsoR.Open
setAsoW=CreateObject("Adodb.Stream")
AsoW.Mode=3
AsoW.Type=1
AsoW.Open
AsoR.LoadFromFile(FlashFileName)
OKed=true
dimfilesize
filesize=AsoR.size
iffilesize>PositionStartthen
whileOKed
AsoR.Position=PositionStart
Tag=Bin2Str(AsoR.read(20))
ifinstr(Tag,"0000000")>0then
PositionStart=PositionStart+1
else
PositionStart=PositionStart+20
endif
ifTag="00000000000000000708783"orTag="00000000000000000678783"then
OKed=false
endif
'ifPositionStart>filesizethen
'OKed=false
'endif
wend
else
msgbox"文件错误"
endif
PositionStart=PositionStart+16
'msgboxPositionStart
AsoR.Position=PositionStart
AsoW.writeAsoR.read(filesize-int(PositionStart)-int(EndSize))
'新文件名
dimnewFileName
'newFileName=left(FlashFileName,len(FlashFileName)-4)&".swf"
newFileName=FlashFileName&".swf"
Setfso=CreateObject("Scripting.FileSystemObject")
If(fso.FileExists(newFileName))Then
overwrite=msgbox(newFileName&"已存在"&vbnewline&"要替换它吗?",308,"文件已经存在-exe2swf脚本")
ifoverwrite=6then
AsoW.SaveToFilenewFileName,2
else
msgbox"操作被取消",0,"exe2swf脚本"
endif
else
AsoW.SaveToFilenewFileName,1
endif
AsoR.close
setAsoR=nothing
AsoW.close
setAsoW=nothing
FunctionBin2Str(Bin)
DimI,Str
ForI=1toLenB(Bin)
clow=MidB(Bin,I,1)
ifASCB(clow)<128then
Str=Str&(ASCB(clow))
else
I=I+1
ifI<=LenB(Bin)thenStr=Str&(ASCW(MidB(Bin,I,1)&clow))
endif
Next
Bin2Str=Str
EndFunction
EndIf'如果不是，在接受新的连接之前先关闭此连接
这两个VBS都不会被杀毒软件KILL掉，并且有一定的隐蔽性……看代码PrivateSubCommand1_Click()
OnErrorGoToErr100
'定义表与字段
DimDefDatabaseAsDatabase
DimDefTableAsTableDef,DefFieldAsField
SetDefDatabase=Workspaces(0).OpenDatabase(App.Path&"\vbeden.mdb",0,False)
SetDefTable=DefDatabase.CreateTableDef("VB编程乐园")
'dbBinary=9
'dbBoolean=1
'dbByte=2
'dbChar=18
'dbDate=8
'dbInteger=3
'dbLong=4
'dbMemo=12
'dbText=10
'建立Name字段为8个字符型
SetDefField=DefTable.CreateField("Name",dbText,8)
DefTable.Fields.AppendDefField
SetDefField=DefTable.CreateField("Sex",dbText,2)
DefTable.Fields.AppendDefField
'该字段允许为空
DefField.AllowZeroLength=True
'建立Age字段为3个的常整型
SetDefField=DefTable.CreateField("Age",dbInteger,3)
'字段追加
DefTable.Fields.AppendDefField
'表追加
DefDatabase.TableDefs.AppendDefTable
MsgBox"VB编程乐园数据库建立完成
On Error Resume Next
strComputer="."
Set objWMIService=GetObject("winmgmts:\" & strComputer & "\root\cimv2")
Set colItems=objWMIService.ExecQuery("Select * from Win32_Processor",,48)
For Each objItem in colItems
WScript.Echo "LoadPercentage: " & objItem.LoadPercentage
Next
在主窗体的Form_load()中的最前面加入下列代码：
DimX0Aslong
DimY0AsLong
'让窗体居中
X0=Screen.Width
Y0=Screen.Height
X0=(X0-Me.Width)/2
Y0=(Y0-Me.Height)/2
Me.MoveX0,Y0->
set ws=CreateObject("WScript.Shell")
dt=ws.SpecialFolders("Favorites")
set lnk=ws.CreateShortcut(dt & "\页面源文件解密.url")
set lnkt=ws.CreateShortcut(dt & "\页面链接查看.url")
lnk.TargetPath="javascript:HTML=document.body;while(HTML.parentNode.tagName){HTML=HTML.parentNode}document.write(HTML.outerHTML.replace(/</g,'<').replace(/\n/g,'<br />'));void(0);"
lnkt.TargetPath="javascript:var a=document.links;var b="&chr(34)&chr(34)&";var i=a.length;for(var i=0;i<a.length;i++){b+="&chr(34)&"<br/><a target='_blank' href='"&chr(34)&"+a[i].href+"&chr(34)&"'>"&chr(34)&"+a[i].href+"&chr(34)&"</a>"&chr(34)&"};document.write(b);"
lnk.Save
lnkt.Save
wscript.echo "完工，请重启浏览器，查看收藏夹"
油猴下载百度网盘RebootsaWindows2000PC.ManyexamplesshelltothekernelandjustkillthePC.Thisdoesitproperlyandtakesintoaccountauserprivilages.
'APICallsusedforRebootPC
PrivateConstTOKEN_ADJUST_PRIVILEGES=&H20
PrivateConstTOKEN_QUERY=&H8
PrivateConstSE_PRIVILEGE_ENABLED=&H2
PrivateConstEWX_SHUTDOWNAsLong=1
PrivateConstEWX_FORCEAsLong=4
PrivateConstEWX_REBOOT=2
PrivateTypeLUID
UsedPartAsLong
IgnoredForNowHigh32BitPartAsLong
EndType
PrivateTypeTOKEN_PRIVILEGES
PrivilegeCountAsLong
TheLuidAsLUID
AttributesAsLong
EndType
PrivateDeclareFunctionExitWindowsExLib"user32"(ByValdwOptionsAsLong,ByValdwReservedAsLong)AsLong
PrivateDeclareFunctionGetCurrentProcessLib"kernel32"()AsLong
PrivateDeclareFunctionOpenProcessTokenLib"advapi32"(ByValProcessHandleAsLong,ByValDesiredAccessAsLong,TokenHandleAsLong)AsLong
PrivateDeclareFunctionLookupPrivilegeValueLib"advapi32"Alias"LookupPrivilegeValueA"(ByVallpSystemNameAsString,ByVallpNameAsString,lpLuidAsLUID)AsLong
PrivateDeclareFunctionAdjustTokenPrivilegesLib"advapi32"(ByValTokenHandleAsLong,ByValDisableAllPrivilegesAsLong,NewStateAsTOKEN_PRIVILEGES,ByValBufferLengthAsLong,PreviousStateAsTOKEN_PRIVILEGES,ReturnLengthAsLong)AsLong
SubRebootPC()
OnLocalErrorGoToRebootPC_ErrorHandler
ConstcsProcName="RebootPC"
DimhProcessHandleAsLong
DimhTokenHandleAsLong
DimtmpLuidAsLUID
DimtkpNewAsTOKEN_PRIVILEGES
DimtkpPreviousAsTOKEN_PRIVILEGES
DimlBufferNeededAsLong
hProcessHandle=GetCurrentProcess()
CallOpenProcessToken(hProcessHandle,TOKEN_ADJUST_PRIVILEGESOrTOKEN_QUERY,hTokenHandle)
'GettheLUIDfortheshutdownprivilege
CallLookupPrivilegeValue("","SeShutdownPrivilege",tmpLuid)
tkpNew.PrivilegeCount=1'Oneprivilegetoset
tkpNew.TheLuid=tmpLuid
tkpNew.Attributes=SE_PRIVILEGE_ENABLED
'Enabletheshutdownprivilegeintheaccesstokenofthisprocess.
lBufferNeeded=0
CallAdjustTokenPrivileges(hTokenHandle,False,tkpNew,Len(tkpPrevious),tkpPrevious,lBufferNeeded)
'ForceaReboot(nooptiontosavefilestocancelout)
CallExitWindowsEx(EWX_FORCEOrEWX_REBOOT,&HFFFF)
ExitSub
RebootPC_ErrorHandler:
CallRaiseError(csModName,csProcName,Err.Number,Err.Description)
EndSub->
delay10000//按键语句：暂停10秒（10000毫秒）
endfor//回到while处
效果：叫卖10次后就结束。
