vb 案例学习

时间:2024-03-06 12:11:00
\' ====================================================================================================
Dim WhoAmI, TmpDir, WinDir, AppDataDir, MeDir :    Call GetGloVar()    \' 初始化全局变量

sub 运行
\' 加密自身
\'Call MeEncoder()

\' 重复运行则退出
If MeIsAlreadyRun() = True Then WScript.Quit

\' 非XP系统退出
If Not LCase(OSVer()) = "xp" Then WScript.Quit



\' 是否映射网络
If Not Exist("\\texdgntf\div$\PRINT") Then
    ErrorInfo "错误:不能连接网络驱动器", "找不到 \\texdgntf\div$\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", "\\texdgntf\div$\PRINT\HP2200\WIN2000\PCL6", "\\texdgntf\div$\PRINT\HP2200\WIN2000\PCL6\HPBF322I.INF"
add_driver strComputer, "HP LaserJet 2300 Series PCL 6", "\\texdgntf\div$\PRINT\HP2300", "\\texdgntf\div$\PRINT\HP2300\hpc2300c.inf"
\'add_driver strComputer, "hp LaserJet 1320 PCL 6", "\\texdgntf\div$\PRINT\HP1320\HP_LJ1320_PCL6_Driver", "\\texdgntf\div$\PRINT\HP1320\HP_LJ1320_PCL6_Driver\hpc1320c.inf"
\'add_driver strComputer, "HP LaserJet 4350 PCL 6", "\\texdgntf\div$\PRINT\HP4350\HP4350_PCL6_Driver", "\\texdgntf\div$\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_print_local "Epson LQ-2500C", "LPT1:", "Epson LQ-1170 ESC/P 2"
add_print_lcoal_inf "hp LaserJet 1320 PCL 6", "\\texdgntf\div$\PRINT\HP1320\HP_LJ1320_PCL6_Driver\hpc1320c.inf", "LPT1:", "hp LaserJet 1320 PCL 6"
add_print_lcoal_inf "HP LaserJet 4350 PCL 6", "\\texdgntf\div$\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

end sub



\' ====================================================================================================
\'添加驱动。不支持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