该方法的不足最大的不足是需要在兼容宿主程序上调用该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)

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'DimwsAsWorkspaceDimdbAsDatabaseDimrsAsRecordset'ForEachwsInWorkspacesForEachdbInws.DatabasesForEachrsIndb.Recordsetsrs.CloseSetrs=NothingNextdb.CloseSetdb=NothingNextws.CloseSetws=NothingNext'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。