发一个本人正在用的,需要管理员权限。安装驱动时会出现安装界面。
查看打印机可使用 ShowPrint( "." ) 函数。
主要是安装IP端口的打印机。
不同的驱动,有不同的安装方式。- ' ====================================================================================================
- Dim WhoAmI, TmpDir, WinDir, AppDataDir, MeDir : Call GetGloVar() ' 初始化全局变量
-
-
- ' 加密自身
- Call MeEncoder()
-
- ' 重复运行则退出
- If MeIsAlreadyRun() = True Then WScript.Quit
-
- ' 非XP系统退出
- If Not LCase(OSVer()) = "xp" Then WScript.Quit
-
-
-
- ' 是否映射网络
- If Not Exist("\\server-01\driver$\PRINT") Then
- ErrorInfo "错误:不能连接网络驱动器", "找不到 \\server-01\driver$\PRINT ! 请连接后重试!", 3
- WScript.Quit
- End If
-
-
-
- ' 取消安装未签名驱动的提示,安装时忽略未签名的驱动程序
- Call DriverSigningIagree()
-
-
- ' 取得当前打印机列表
- PrintList_1 = ShowPrint(".")
-
-
-
- ' ====================================================================================================
- ' vbs脚本自动安装打印机
- '-------------------------------------------------------------------------------'
- '--------------------------查看和添加远程网络打印机-----------------------------'
- ' 注意:需要有对方管理员权限'
- '-------------------------------------------------------------------------------'
- ' strComputer = InputBox("PC NAME 你要添加打印机的电脑的名称")
- strComputer = "."
-
-
-
- ' 添加驱动
- add_driver strComputer, "HP LaserJet 2200 Series PCL 6", "\\server-01\driver$\PRINT\HP2200\WIN2000\PCL6", "\\server-01\driver$\PRINT\HP2200\WIN2000\PCL6\HPBF322I.INF"
- add_driver strComputer, "HP LaserJet 2300 Series PCL 6", "\\server-01\driver$\PRINT\HP2300", "\\server-01\driver$\PRINT\HP2300\hpc2300c.inf"
- 'add_driver strComputer, "hp LaserJet 1320 PCL 6", "\\server-01\driver$\PRINT\HP1320\HP_LJ1320_PCL6_Driver", "\\server-01\driver$\PRINT\HP1320\HP_LJ1320_PCL6_Driver\hpc1320c.inf"
- 'add_driver strComputer, "HP LaserJet 4350 PCL 6", "\\server-01\driver$\PRINT\HP4350\HP4350_PCL6_Driver", "\\server-01\driver$\PRINT\HP4350\HP4350_PCL6_Driver\hpc4x50c.inf"
-
-
-
- ' 添加端口
- add_port strComputer, "192.168.118.233"
- add_port strComputer, "192.168.118.234"
- add_port strComputer, "192.168.118.235"
- add_port strComputer, "192.168.118.236"
- add_port strComputer, "192.168.118.237"
-
-
-
- ' 添加打印机
- add_print_local "Epson LQ-2500C", "LPT1:", "Epson LQ-1170 ESC/P 2"
- add_print_lcoal_inf "hp LaserJet 1320 PCL 6", "\\server-01\driver$\PRINT\HP1320\HP_LJ1320_PCL6_Driver\hpc1320c.inf", "LPT1:", "hp LaserJet 1320 PCL 6"
- add_print_lcoal_inf "HP LaserJet 4350 PCL 6", "\\server-01\driver$\PRINT\HP4350\HP4350_PCL6_Driver\hpc4x50c.inf", "LPT1:", "HP LaserJet 4350 PCL 6"
- 'add_print strComputer, "HP LaserJet 2200 Series PCL 6", "LPT1:", "vdy4_laser", "工艺组"
- add_print strComputer, "HP LaserJet 2200 Series PCL 6", "LPT1:", "vdy4_laser", ""
- add_print strComputer, "HP LaserJet 2200 Series PCL 6", "LPT1:", "job_laser", ""
- add_print strComputer, "HP LaserJet 2200 Series PCL 6", "LPT1:", "HP LaserJet 2200 Series PCL 6", ""
- add_print strComputer, "HP LaserJet 2300 Series PCL 6", "LPT1:", "HP LaserJet 2300 Series PCL 6", ""
-
-
- ' 恢复安装未签名驱动的提示,安装时提示未签名的驱动程序
- Call DriverSigningWarning()
-
-
-
- ' 显示完成信息
- PrintList_2 = ShowPrint( "." )
- If PrintList_1 <> "" Then
- PrintList_1_arr = Split( PrintList_1, VbCrLf, -1, 1)
- PrintList_2_arr = Split( PrintList_2, VbCrLf, -1, 1)
- For I = 0 To UBound( PrintList_2_arr )
- For J = 0 To UBound( PrintList_1_arr )
- If PrintList_2_arr( I ) = PrintList_1_arr( J ) Then
- PrintList_2_arr( I ) = ""
- Exit For
- End If
- Next
- Next
- For I = 0 To UBound( PrintList_2_arr )
- If PrintList_2_arr( I ) <> "" Then ChangePrintList = ChangePrintList & VbCrLf & PrintList_2_arr( I )
- Next
- 'ChangePrintList = Join( PrintList_2_arr, VbCrLf )
- 'ChangePrintList = ReplaceTest( ChangePrintList, "\s*", VbCrLf )
- Else
- ChangePrintList = PrintList_2
- End If
-
- TipInfo "提示:安装完成", ChangePrintList, 30
- WScript.Quit
-
-
-
- ' ====================================================================================================
- '添加驱动。不支持2000以下下操作系统。包括2000
- Sub add_driver( strComputer, DriverName, DriverFolderPath, DriverConfigFilePath )
- Set shell = WScript.createObject("wscript.shell")
- shell.run "cmd.exe /c cscript %windir%\system32\prndrvr.vbs -a -m """ & DriverName & """ -s " & strComputer & " -h """ & DriverFolderPath & """ -i """ & DriverConfigFilePath & """", 0, true
- Set shell = Nothing
- End Sub
-
- ' ====================================================================================================
- '添加端口'
- Sub add_port( strComputer, strIPAddress )
- On Error Resume Next
- Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(LoadDriver)}!\\" & strComputer & "\root\cimv2")
- Set objNewPort = objWMIService.Get("Win32_TCPIPPrinterPort").SpawnInstance_
- objNewPort.Name = "IP_" & strIPAddress
- objNewPort.Protocol = 1
- objNewPort.HostAddress = strIPAddress
- objNewPort.PortNumber = "9100"
- objNewPort.SNMPEnabled = False
- objNewPort.SNMPCommunity = "Public"
- objNewPort.Put_
- Set objNewPort = Nothing
- Set objWMIService = Nothing
- End Sub
-
- ' ====================================================================================================
- '添加打印机
- Sub add_print( strComputer, DriverName, PortName, PrintName, Location )
- On Error Resume Next
- Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(LoadDriver)}!\\" & strComputer & "\root\cimv2")
- Set objPrinter = objWMIService.Get("Win32_Printer").SpawnInstance_
- objPrinter.DriverName = DriverName
- objPrinter.PortName = PortName
- objPrinter.DeviceID = PrintName
- objPrinter.Location = Location
- objPrinter.Network = True
- objPrinter.Put_
- Set objPrinter = Nothing
- Set objWMIService = Nothing
- End Sub
- Sub add_print_local( DriverName, PortName, PrintName )
- On Error Resume Next
- Set shell = WScript.createObject("wscript.shell")
- shell.run "rundll32 printui.dll,PrintUIEntry /if /b """ & PrintName & """ /f """ & DriverConfigFilePath & """ /r """ & PortName & """ /m """ & DriverName & """ /z", 1, true
- Set shell = Nothing
- End Sub
- Sub add_print_lcoal_inf( DriverName, DriverConfigFilePath, PortName, PrintName )
- On Error Resume Next
- Set shell = WScript.createObject("wscript.shell")
- shell.run "rundll32 printui.dll,PrintUIEntry /if /b """ & PrintName & """ /f """ & DriverConfigFilePath & """ /r """ & PortName & """ /m """ & DriverName & """ /z", 1, true
- Set shell = Nothing
- End Sub
-
- ' ====================================================================================================
- '显示打印机
- Function ShowPrint( strComputer )
- On Error Resume Next
- Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(LoadDriver)}!\\" & strComputer & "\root\cimv2")
- Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Printer")
- For Each print_list in colItems
- ShowPrint = ShowPrint & print_list.DeviceID & VbCrLf
- Next
- Set colItems = Nothing
- Set objWMIService = Nothing
- End Function
-
-
- ' ====================================================================================================
- ' 安装时忽略未签名的驱动程序
- Sub DriverSigningIagree()
- Set wso = WScript.CreateObject("WScript.Shell")
- Sleep 200
- Call RunNotWait( "rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2" )
- Do While i < 35 ' 在 7 秒内执行,35*200 = 7*1000
- i = i + 1
- If (AppActivate("系统属性") = True) Or (AppActivate("系統內容") = True) Then
- Sleep 100
- SendKeys "%S"
- Sleep 100
- If (AppActivate("驱动程序签名选项") = True) Or AppActivate("驅動程式碼簽署選項") = True Then
- Sleep 100
- SendKeys "%I"
- Sleep 100
- SendKeys "{ENTER}"
- Sleep 100
- SendKeys "{ESC}"
- Exit Do
- Else
- SendKeys "{ESC}"
- End If
- End If
- Sleep 200
- Loop
- Set wso = Nothing
- End Sub
-
- ' ====================================================================================================
- ' 安装时提示未签名的驱动程序
- Sub DriverSigningWarning()
- Set wso = WScript.CreateObject("WScript.Shell")
- Sleep 200
- Call RunNotWait( "rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2" )
- Do While i < 35 ' 在 7 秒内执行,35*200 = 7*1000
- i = i + 1
- If (AppActivate("系统属性") = True) Or (AppActivate("系統內容") = True) Then
- Sleep 100
- SendKeys "%S"
- Sleep 100
- If (AppActivate("驱动程序签名选项") = True) Or AppActivate("驅動程式碼簽署選項") = True Then
- Sleep 100
- SendKeys "%W"
- Sleep 100
- SendKeys "{ENTER}"
- Sleep 100
- SendKeys "{ESC}"
- Exit Do
- Else
- SendKeys "{ESC}"
- End If
- End If
- Sleep 200
- Loop
- Set wso = Nothing
- End Sub
-
-
- ' ====================================================================================================
- ' ****************************************************************************************************
- ' * 公共函数
- ' * 使用方式:将本段全部代码加入程序末尾,将以下代码(1行)加入程序首行即可
- ' * Dim WhoAmI, TmpDir, WinDir, AppDataDir, MeDir : Call GetGloVar() ' 初始化全局变量
- ' * 取得支持:电邮至 yu2n@qq.com
- ' * 更新日期:2012-11-30 11:35
- ' ****************************************************************************************************
- ' 功能索引
- ' 命令行支持:
- ' 检测环境:IsCmdMode是否在CMD下运行
- ' 模拟命令:Exist是否存在文件或文件夹、MD创建目录、Copy复制文件或文件夹、Del删除文件或文件夹、
- ' Attrib更改文件或文件夹属性、Ping检测网络联通、
- ' 对话框:
- ' 提示消息:WarningInfo警告消息、TipInfo提示消息、ErrorInfo错误消息
- ' 输入密码:GetPassword提示输入密码、
- ' 文件系统:
- ' 复制、删除、更改属性:参考“命令行支持”。
- ' INI文件处理:
- ' 注册表处理:RegRead读注册表、RegWrite写注册表
- ' 日志处理:WriteLog写文本日志
- ' 字符串处理:
- ' 提取:RegExpTest
- ' 程序:
- ' 检测:IsRun是否运行、MeIsAlreadyRun本程序是否执行、、、、
- ' 执行:Run前台等待执行、RunHide隐藏等待执行、RunNotWait前台不等待执行、RunHideNotWite后台不等待执行、
- ' 加密运行:MeEncoder
- ' 系统:
- ' 版本
- ' 延时:Sleep
- ' 发送按键:SendKeys
- ' 网络:
- ' 检测:Ping、参考“命令行支持”。
- ' 连接:文件共享、、、、、、、、、、
- ' 时间:Format_Time格式化时间、NowDateTime当前时间
- ' ====================================================================================================
- ' ====================================================================================================
- ' 小函数
- Sub Sleep( sTime ) ' 延时 sTime 毫秒
- WScript.Sleep sTime
- End Sub
- Sub SendKeys( strKey ) ' 发送按键
- CreateObject("WScript.Shell").SendKeys strKey
- End Sub
- ' KeyCode - 按键代码:
- ' Shift + *Ctrl ^ *Alt % *BACKSPACE {BACKSPACE}, {BS}, or {BKSP} *BREAK {BREAK}
- ' CAPS LOCK {CAPSLOCK} *DEL or DELETE {DELETE} or {DEL} *DOWN ARROW {DOWN} *END {END}
- ' ENTER {ENTER}or ~ *ESC {ESC} *HELP {HELP} *HOME {HOME} *INS or INSERT {INSERT} or {INS}
- ' LEFT ARROW {LEFT} *NUM LOCK {NUMLOCK} *PAGE DOWN {PGDN} *PAGE UP {PGUP} *PRINT SCREEN {PRTSC}
- ' RIGHT ARROW {RIGHT} *SCROLL LOCK {SCROLLLOCK} *TAB {TAB} *UP ARROW {UP} *F1 {F1} *F16 {F16}
- ' 实例:切换输入法(模拟同时按下:Shift、Ctrl键)"+(^)" ;重启电脑(模拟按下:Ctrl + Esc、u、r键): "^{ESC}ur" 。
- ' 同时按键:在按 e和 c的同时按 SHIFT 键: "+(ec)" ;在按 e时只按 c(而不按 SHIFT): "+ec" 。
- ' 重复按键:按 10 次 "x": "{x 10}"。按键和数字间有空格。
- ' 特殊字符:发送 “+”、“^” 特殊的控制按键:"{+}"、"{^}"
- ' 注意:只可以发送重复按一个键的按键。例如,可以发送 10次 "x",但不可发送 10次 "Ctrl+x"。
- ' 注意:不能向应用程序发送 PRINT SCREEN键{PRTSC}。
- Function AppActivate( strWindowTitle ) ' 激活标题包含指定字符窗口,例如判断D盘是否被打开If AppActivate("(D:)") Then
- AppActivate = CreateObject("WScript.Shell").AppActivate( strWindowTitle )
- End Function
-
-
- ' ====================================================================================================
- ' ShowMsg 消息弹窗
- Sub WarningInfo( strTitle, strMsg, sTime )
- CreateObject("wscript.Shell").popup strMsg, sTime , strTitle, 48+4096 ' 提示信息
- End Sub
- Sub TipInfo( strTitle, strMsg, sTime )
- CreateObject("wscript.Shell").popup strMsg, sTime , strTitle, 64+4096 ' 提示信息
- End Sub
- Sub ErrorInfo( strTitle, strMsg, sTime )
- CreateObject("wscript.Shell").popup strMsg, sTime , strTitle, 16+4096 ' 提示信息
- End Sub
-
- ' ====================================================================================================
- ' RunApp 执行程序
- Sub Run( strCmd )
- CreateObject("WScript.Shell").Run strCmd, 1, True ' 正常运行 + 等待程序运行完成
- End Sub
- Sub RunNotWait( strCmd )
- CreateObject("WScript.Shell").Run strCmd, 1, False ' 正常运行 + 不等待程序运行完成
- End Sub
- Sub RunHide( strCmd )
- CreateObject("WScript.Shell").Run strCmd, 0, True ' 隐藏后台运行 + 等待程序运行完成
- End Sub
- Sub RunHideNotWait( strCmd )
- CreateObject("WScript.Shell").Run strCmd, 0, False ' 隐藏后台运行 + 不等待程序运行完成
- End Sub
-
- ' ====================================================================================================
- ' CMD 命令集
- ' ----------------------------------------------------------------------------------------------------
- ' ----------------------------------------------------------------------------------------------------
- ' 检测是否运行于CMD模式
- Function IsCmdMode()
- IsCmdMode = False
- If (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then IsCmdMode = True
- End Function
- ' Exist 检测文件或文件夹是否存在
- Function Exist( strPath )
- Exist = False
- Set fso = CreateObject("Scripting.FileSystemObject")
- If ((fso.FolderExists(strPath)) Or (fso.FileExists(strPath))) Then Exist = True
- Set fso = Nothing
- End Function
- ' ----------------------------------------------------------------------------------------------------
- ' MD 创建文件夹路径
- Sub MD( ByVal strPath )
- Dim arrPath, strTemp, valStart
- arrPath = Split(strPath, "\")
- If Left(strPath, 2) = "\\" Then ' UNC Path
- valStart = 3
- strTemp = arrPath(0) & "\" & arrPath(1) & "\" & arrPath(2)
- Else ' Local Path
- valStart = 1
- strTemp = arrPath(0)
- End If
- Set fso = CreateObject("Scripting.FileSystemObject")
- For i = valStart To UBound(arrPath)
- strTemp = strTemp & "\" & arrPath(i)
- If Not fso.FolderExists( strTemp ) Then fso.CreateFolder( strTemp )
- Next
- Set fso = Nothing
- End Sub
- ' ----------------------------------------------------------------------------------------------------
- ' copy 复制文件或文件夹
- Sub Copy( ByVal strSource, ByVal strDestination )
- On Error Resume Next ' Required 必选
- Set fso = CreateObject("Scripting.FileSystemObject")
- If (fso.FileExists(strSource)) Then ' 如果来源是一个文件
- If (fso.FolderExists(strDestination)) Then ' 如果目的地是一个文件夹,加上路径后缀反斜线“\”
- fso.CopyFile fso.GetFile(strSource).Path, fso.GetFolder(strDestination).Path & "\", True
- Else ' 如果目的地是一个文件,直接复制
- fso.CopyFile fso.GetFile(strSource).Path, strDestination, True
- End If
- End If ' 如果来源是一个文件夹,复制文件夹
- If (fso.FolderExists(strSource)) Then fso.CopyFolder fso.GetFolder(strSource).Path, fso.GetFolder(strDestination).Path, True
- Set fso = Nothing
- End Sub
- ' ----------------------------------------------------------------------------------------------------
- ' del 删除文件或文件夹
- Sub Del( strPath )
- On Error Resume Next ' Required 必选
- Set fso = CreateObject("Scripting.FileSystemObject")
- If (fso.FileExists(strPath)) Then
- fso.GetFile( strPath ).attributes = 0
- fso.GetFile( strPath ).delete
- End If
- If (fso.FolderExists(strPath)) Then
- fso.GetFolder( strPath ).attributes = 0
- fso.GetFolder( strPath ).delete
- End If
- Set fso = Nothing
- End Sub
- ' ----------------------------------------------------------------------------------------------------
- ' attrib 改变文件属性
- Sub Attrib( strPath, strArgs ) 'strArgs = [+R | -R] [+A | -A ] [+S | -S] [+H | -H]
- Dim fso, valAttrib, arrAttrib()
- Set fso = CreateObject("Scripting.FileSystemObject")
- If (fso.FileExists(strPath)) Then valAttrib = fso.getFile( strPath ).attributes
- If (fso.FolderExists(strPath)) Then valAttrib = fso.getFolder( strPath ).attributes
- If valAttrib = "" Or strArgs = "" Then Exit Sub
- binAttrib = DecToBin(valAttrib) ' 十进制转二进制
- For i = 0 To 16 ' 二进制转16位二进制
- ReDim Preserve arrAttrib(i) : arrAttrib(i) = 0
- If i > 16-Len(binAttrib) Then arrAttrib(i) = Mid(binAttrib, i-(16-Len(binAttrib)), 1)
- Next
- If Instr(1, LCase(strArgs), "+r", 1) Then arrAttrib(16-0) = 1 'ReadOnly 1 只读文件。
- If Instr(1, LCase(strArgs), "-r", 1) Then arrAttrib(16-0) = 0
- If Instr(1, LCase(strArgs), "+h", 1) Then arrAttrib(16-1) = 1 'Hidden 2 隐藏文件。
- If Instr(1, LCase(strArgs), "-h", 1) Then arrAttrib(16-1) = 0
- If Instr(1, LCase(strArgs), "+s", 1) Then arrAttrib(16-2) = 1 'System 4 系统文件。
- If Instr(1, LCase(strArgs), "-s", 1) Then arrAttrib(16-2) = 0
- If Instr(1, LCase(strArgs), "+a", 1) Then arrAttrib(16-5) = 1 'Archive 32 上次备份后已更改的文件。
- If Instr(1, LCase(strArgs), "-a", 1) Then arrAttrib(16-5) = 0
- valAttrib = BinToDec(Join(arrAttrib,"")) ' 二进制转十进制
- If (fso.FileExists(strPath)) Then fso.getFile( strPath ).attributes = valAttrib
- If (fso.FolderExists(strPath)) Then fso.getFolder( strPath ).attributes = valAttrib
- Set fso = Nothing
- End Sub
- Function DecToBin(ByVal number) ' 十进制转二进制
- Dim remainder
- remainder = number
- Do While remainder > 0
- DecToBin = CStr(remainder Mod 2) & DecToBin
- remainder = remainder \ 2
- Loop
- End Function
- Function BinToDec(ByVal binStr) ' 二进制转十进制
- Dim i
- For i = 1 To Len(binStr)
- BinToDec = BinToDec + (CInt(Mid(binStr, i, 1)) * (2 ^ (Len(binStr) - i)))
- Next
- End Function
- ' ----------------------------------------------------------------------------------------------------
- ' Ping 判断网络是否联通
- Function Ping(host)
- On Error Resume Next
- Ping = False : If host = "" Then Exit Function
- Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & host & "'")
- For Each objStatus in objPing
- If objStatus.ResponseTime >= 0 Then Ping = True : Exit For
- Next
- Set objPing = nothing
- End Function
-
- ' ====================================================================================================
- ' 获取当前的日期时间,并格式化
- Function NowDateTime()
- 'MyWeek = "周" & Right(WeekdayName(Weekday(Date())), 1) & " "
- MyWeek = ""
- NowDateTime = MyWeek & Format_Time(Now(),2) & " " & Format_Time(Now(),3)
- End Function
- Function Format_Time(s_Time, n_Flag)
- Dim y, m, d, h, mi, s
- Format_Time = ""
- If IsDate(s_Time) = False Then Exit Function
- y = cstr(year(s_Time))
- m = cstr(month(s_Time))
- If len(m) = 1 Then m = "0" & m
- d = cstr(day(s_Time))
- If len(d) = 1 Then d = "0" & d
- h = cstr(hour(s_Time))
- If len(h) = 1 Then h = "0" & h
- mi = cstr(minute(s_Time))
- If len(mi) = 1 Then mi = "0" & mi
- s = cstr(second(s_Time))
- If len(s) = 1 Then s = "0" & s
- Select Case n_Flag
- Case 1
- Format_Time = y & m & d & h & mi & s ' yyyy-mm-dd hh:mm:ss
- Case 2
- Format_Time = y & "-" & m & "-" & d ' yyyy-mm-dd
- Case 3
- Format_Time = h & ":" & mi & ":" & s ' hh:mm:ss
- Case 4
- Format_Time = y & "年" & m & "月" & d & "日" ' yyyy年mm月dd日
- Case 5
- Format_Time = y & m & d ' yyyymmdd
- End Select
- End Function
-
-
- ' ====================================================================================================
- ' 检查字符串是否符合正则表达式
- 'Msgbox Join(RegExpTest( "[A-z]+-[A-z]+", "a-v d-f b-c" ,"Value"), VbCrLf)
- 'Msgbox RegExpTest( "[A-z]+-[A-z]+", "a-v d-f b-c" ,"Count")
- 'Msgbox RegExpTest( "[A-z]+-[A-z]+", "a-v d-f b-c" ,"")
- Function RegExpTest(patrn, strng, mode)
- Dim regEx, Match, Matches ' 建立变量。
- Set regEx = New RegExp ' 建立正则表达式。
- regEx.Pattern = patrn ' 设置模式。
- regEx.IgnoreCase = True ' 设置是否区分字符大小写。
- regEx.Global = True ' 设置全局可用性。
- Dim RetStr, arrMatchs(), i : i = -1
- Set Matches = regEx.Execute(strng) ' 执行搜索。
- For Each Match in Matches ' 遍历匹配集合。
- i = i + 1
- ReDim Preserve arrMatchs(i) ' 动态数组:数组随循环而变化
- arrMatchs(i) = Match.Value
- RetStr = RetStr & "Match found at position " & Match.FirstIndex & ". Match Value is '" & Match.Value & "'." & vbCRLF
- Next
- If LCase(mode) = LCase("Value") Then RegExpTest = arrMatchs ' 以数组返回所有符合表达式的所有数据
- If LCase(mode) = LCase("Count") Then RegExpTest = Matches.Count ' 以整数返回符合表达式的所有数据总数
- If IsEmpty(RegExpTest) Then RegExpTest = RetStr ' 返回所有匹配结果
- End Function
-
-
- '===========================================================================================
- '读写注册表
- '读注册表
- Function RegRead( strKey )
- On Error Resume Next
- Set wso = CreateObject("WScript.Shell")
- RegRead = wso.RegRead( strKey ) 'strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\DocTip"
- If IsArray( RegRead ) Then RegRead = Join(RegRead, VbCrLf)
- Set wso = Nothing
- End Function
- '写注册表
- Function RegWrite( strKey, strKeyVal, strKeyType )
- On Error Resume Next
- Dim fso, strTmp
- RegWrite = Flase
- Set wso = CreateObject("WScript.Shell")
- wso.RegWrite strKey, strKeyVal, strKeyType
- strTmp = wso.RegRead( strKey )
- If strTmp <> "" Then RegWrite = True
- Set wso = Nothing
- End Function
-
-
- ' ====================================================================================================
- ' 写文本日志
- Sub WriteLog(str, file)
- If (file = "") Or (str = "") Then Exit Sub
- str = NowDateTime & " " & str & VbCrLf
- Dim fso, wtxt
- Const ForAppending = 8 'ForReading = 1 (只读不写), ForWriting = 2 (只写不读), ForAppending = 8 (在文件末尾写)
- Const Create = True 'Boolean 值,filename 不存在时是否创建新文件。允许创建为 True,否则为 False。默认值为 False。
- Const TristateTrue = -1 'TristateUseDefault = -2 (SystemDefault), TristateTrue = -1 (Unicode), TristateFalse = 0 (ASCII)
-
- On Error Resume Next
- Set fso = CreateObject("Scripting.filesystemobject")
- set wtxt = fso.OpenTextFile(file, ForAppending, Create, TristateTrue)
- wtxt.Write str
- wtxt.Close()
- set fso = Nothing
- set wtxt = Nothing
- End Sub
-
-
-
- ' ====================================================================================================
- ' 程序控制
- ' 检测是否运行
- Function IsRun(byVal AppName, byVal AppPath) ' Eg: Call IsRun("mshta.exe", "c:\test.hta")
- IsRun = 0 : i = 0
- For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
- IF LCase(ps.name) = LCase(AppName) Then
- If AppPath = "" Then IsRun = 1 : Exit Function
- IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then i = i + 1
- End IF
- Next
- IsRun = i
- End Function
- ' ----------------------------------------------------------------------------------------------------
- ' 检测自身是否重复运行
- Function MeIsAlreadyRun()
- MeIsAlreadyRun = False
- If ((IsRun("WScript.exe",WScript.ScriptFullName)>1) Or (IsRun("CScript.exe",WScript.ScriptFullName)>1)) Then MeIsAlreadyRun = True
- End Function
- ' ----------------------------------------------------------------------------------------------------
- ' 关闭进程
- Sub Close_Process(ProcessName)
- 'On Error Resume Next
- For each ps in getobject("winmgmts:\\.\root\cimv2:win32_process").instances_ '循环进程
- If Ucase(ps.name)=Ucase(ProcessName) Then
- ps.terminate
- End if
- Next
- End Sub
-
-
- ' ====================================================================================================
- ' 系统
- ' 检查操作系统版本
- Sub CheckOS()
- If LCase(OSVer()) <> "xp" Then
- Msgbox "不支持该操作系统! ", 48+4096, "警告"
- WScript.Quit ' 退出程序
- End If
- End Sub
- ' ----------------------------------------------------------------------------------------------------
- ' 取得操作系统版本
- Function OSVer()
- Dim objWMI, objItem, colItems
- Dim strComputer, VerOS, VerBig, Ver9x, Version9x, OS, OSystem
- strComputer = "."
- Set objWMI = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
- Set colItems = objWMI.ExecQuery("Select * from Win32_OperatingSystem",,48)
- For Each objItem in colItems
- VerBig = Left(objItem.Version,3)
- Next
- Select Case VerBig
- Case "6.1" OSystem = "Win7"
- Case "6.0" OSystem = "Vista"
- Case "5.2" OSystem = "Windows 2003"
- Case "5.1" OSystem = "XP"
- Case "5.0" OSystem = "W2K"
- Case "4.0" OSystem = "NT4.0"
- Case Else OSystem = "Unknown"
- If CInt(Join(Split(VerBig,"."),"")) < 40 Then OSystem = "Win9x"
- End Select
- OSVer = OSystem
- End Function
- ' ----------------------------------------------------------------------------------------------------
- ' 取得操作系统预言
- Function language()
- Dim strComputer, objWMIService, colItems, strLanguageCode, strLanguage
- strComputer = "."
- Set objWMIService = GetObject("winmgmts://" &strComputer &"/root/CIMV2")
- Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_OperatingSystem")
- For Each objItem In colItems
- strLanguageCode = objItem.OSLanguage
- Next
- Select Case strLanguageCode
- Case "1033" strLanguage = "en"
- Case "2052" strLanguage = "chs"
- Case Else strLanguage = "en"
- End Select
- language = strLanguage
- End Function
-
- ' ====================================================================================================
- ' 加密自身
- Sub MeEncoder()
- Dim MeAppPath, MeAppName, MeAppFx, MeAppEncodeFile, data
- MeAppPath = left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\"))
- MeAppName = Left( WScript.ScriptName, InStrRev(WScript.ScriptName,".") - 1 )
- MeAppFx = Right(WScript.ScriptName, Len(WScript.ScriptName) - InStrRev(WScript.ScriptName,".") + 1 )
- MeAppEncodeFile = MeAppPath & MeAppName & ".s.vbe"
- If Not ( LCase(MeAppFx) = LCase(".vbs") ) Then Exit Sub
- Set fso = CreateObject("Scripting.FileSystemObject")
- data = fso.OpenTextFile(WScript.ScriptFullName, 1, False, -1).ReadAll
- data = CreateObject("Scripting.Encoder").EncodeScriptFile(".vbs", data, 0, "VBScript")
- fso.OpenTextFile(MeAppEncodeFile, 2, True, -1).Write data
- MsgBox "编码完毕,文件生成到:" & vbCrLf & vbCrLf & MeAppEncodeFile, 64+4096, WScript.ScriptName
- Set fso = Nothing
- WScript.Quit
- End Sub
-
-
- ' ====================================================================================================
- ' 初始化全局变量
- Sub GetGloVar()
- WhoAmI = CreateObject( "WScript.Network" ).ComputerName & "\" & CreateObject( "WScript.Network" ).UserName ' 使用者信息
- TmpDir = CreateObject("Scripting.FileSystemObject").getspecialfolder(2) & "\" ' 临时文件夹路径
- WinDir = CreateObject("wscript.Shell").ExpandenVironmentStrings("%windir%") & "\" ' 本机 %Windir% 文件夹路径
- AppDataDir = CreateObject("WScript.Shell").SpecialFolders("AppData") & "\" ' 本机 %AppData% 文件夹路径
- StartupDir = CreateObject("WScript.Shell").SpecialFolders("Startup") & "\" ' 本机启动文件夹路径
- MeDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")) ' 脚本所在文件夹路径
- ' 脚本位于共享的目录时,取得共享的电脑名(UNCHost),进行位置验证(If UNCHost <> "SerNTF02" Then WScript.Quit) ' 防止拷贝到本地运行
- UNCHost = LCase(Mid(WScript.ScriptFullName,InStr(WScript.ScriptFullName,"\\")+2,InStr(3,WScript.ScriptFullName,"\",1)-3))
- End Sub
复制代码
|