vb 案例学习

' ====================================================================================================

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 ！ 请连接后重试！",

    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, -, )

    PrintList_2_arr = Split( PrintList_2, VbCrLf, -, )

    For I =  To UBound( PrintList_2_arr )

        For J =  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 =  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,

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 & """", , 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 =

    objNewPort.HostAddress = strIPAddress

    objNewPort.PortNumber = ""

    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", , 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", , 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

    Call RunNotWait( "rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2" )

    Do While i <     ' 在 7 秒内执行，35*200 = 7*1000

        i = i +

        If (AppActivate("系统属性") = True) Or (AppActivate("系統內容") = True) Then

            Sleep

            SendKeys "%S"

            Sleep

            If (AppActivate("驱动程序签名选项") = True) Or AppActivate("驅動程式碼簽署選項") = True Then

                Sleep

                SendKeys "%I"

                Sleep

                SendKeys "{ENTER}"

                Sleep

                SendKeys "{ESC}"

                Exit Do

            Else

                SendKeys "{ESC}"

            End If

        End If

        Sleep

    Loop

    Set wso = Nothing

End Sub

' ====================================================================================================

' 安装时提示未签名的驱动程序

Sub DriverSigningWarning()

    Set wso = WScript.CreateObject("WScript.Shell")

    Sleep

    Call RunNotWait( "rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2" )

    Do While i <     ' 在 7 秒内执行，35*200 = 7*1000

        i = i +

        If (AppActivate("系统属性") = True) Or (AppActivate("系統內容") = True) Then

            Sleep

            SendKeys "%S"

            Sleep

            If (AppActivate("驱动程序签名选项") = True) Or AppActivate("驅動程式碼簽署選項") = True Then

                Sleep

                SendKeys "%W"

                Sleep

                SendKeys "{ENTER}"

                Sleep

                SendKeys "{ESC}"

                Exit Do

            Else

                SendKeys "{ESC}"

            End If

        End If

        Sleep

    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, +    ' 提示信息

End Sub

Sub TipInfo( strTitle, strMsg, sTime )

    CreateObject("wscript.Shell").popup strMsg, sTime , strTitle, +    ' 提示信息

End Sub

Sub ErrorInfo( strTitle, strMsg, sTime )

    CreateObject("wscript.Shell").popup strMsg, sTime , strTitle, +    ' 提示信息

End Sub

' ====================================================================================================

' RunApp 执行程序

Sub Run( strCmd )

    CreateObject("WScript.Shell").Run strCmd, , True       ' 正常运行 + 等待程序运行完成

End Sub

Sub RunNotWait( strCmd )

    CreateObject("WScript.Shell").Run strCmd, , False      ' 正常运行 + 不等待程序运行完成

End Sub

Sub RunHide( strCmd )

    CreateObject("WScript.Shell").Run strCmd, , True       ' 隐藏后台运行 + 等待程序运行完成

End Sub

Sub RunHideNotWait( strCmd )

    CreateObject("WScript.Shell").Run strCmd, , False      ' 隐藏后台运行 + 不等待程序运行完成

End Sub

' ====================================================================================================

' CMD 命令集

' ----------------------------------------------------------------------------------------------------

' ----------------------------------------------------------------------------------------------------

' 检测是否运行于CMD模式

Function IsCmdMode()

    IsCmdMode = False

    If (LCase(Right(WScript.FullName,)) = 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, ) = "\\" Then    ' UNC Path

        valStart =

        strTemp = arrPath() & "\" & arrPath() & "\" & arrPath()

    Else                              ' Local Path

        valStart =

        strTemp = arrPath()

    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 =

        fso.GetFile( strPath ).delete

    End If

    If (fso.FolderExists(strPath)) Then

        fso.GetFolder( strPath ).attributes =

        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 =  To                    ' 二进制转16位二进制

        ReDim Preserve arrAttrib(i) : arrAttrib(i) =

        If i > -Len(binAttrib) Then arrAttrib(i) = Mid(binAttrib, i-(-Len(binAttrib)), )

    Next

    If Instr(, LCase(strArgs), "+r", ) Then arrAttrib(-) =    'ReadOnly 1 只读文件。

    If Instr(, LCase(strArgs), "-r", ) Then arrAttrib(-) =

    If Instr(, LCase(strArgs), "+h", ) Then arrAttrib(-) =    'Hidden 2 隐藏文件。

    If Instr(, LCase(strArgs), "-h", ) Then arrAttrib(-) =

    If Instr(, LCase(strArgs), "+s", ) Then arrAttrib(-) =    'System 4 系统文件。

    If Instr(, LCase(strArgs), "-s", ) Then arrAttrib(-) =

    If Instr(, LCase(strArgs), "+a", ) Then arrAttrib(-) =    'Archive 32 上次备份后已更改的文件。

    If Instr(, LCase(strArgs), "-a", ) Then arrAttrib(-) =

    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 >

      DecToBin = CStr(remainder Mod ) & DecToBin

      remainder = remainder \

   Loop

End Function

Function BinToDec(ByVal binStr)    ' 二进制转十进制

   Dim i

   For i =  To Len(binStr)

      BinToDec = BinToDec + (CInt(Mid(binStr, i, )) * ( ^ (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 >=  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(),) & " " & Format_Time(Now(),)

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) =  Then m = "" & m

    d = cstr(day(s_Time))

        If len(d) =  Then d = "" & d

    h = cstr(hour(s_Time))

        If len(h) =  Then h = "" & h

    mi = cstr(minute(s_Time))

        If len(mi) =  Then mi = "" & mi

    s = cstr(second(s_Time))

        If len(s) =  Then s = "" & s

    Select Case n_Flag

        Case

            Format_Time = y  & m & d  & h  & mi  & s    ' yyyy-mm-dd hh:mm:ss

        Case

            Format_Time = y & "-" & m & "-" & d    ' yyyy-mm-dd

        Case

            Format_Time = h & ":" & mi & ":" & s   ' hh:mm:ss

        Case

            Format_Time = y & "年" & m & "月" & d & "日"    ' yyyy年mm月dd日

        Case

            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 = -

    Set Matches = regEx.Execute(strng)     ' 执行搜索。

    For Each Match in Matches              ' 遍历匹配集合。

        i = i +

        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 =          'ForReading = 1 (只读不写), ForWriting = 2 (只写不读), ForAppending = 8 (在文件末尾写)

    Const Create = True            'Boolean 值，filename 不存在时是否创建新文件。允许创建为 True，否则为 False。默认值为 False。

    Const TristateTrue = -        '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 =  : i =

    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_

        IF LCase(ps.name) = LCase(AppName) Then

            If AppPath = "" Then IsRun =  : Exit Function

            IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then i = i +

        End IF

    Next

    IsRun = i

End Function

' ----------------------------------------------------------------------------------------------------

' 检测自身是否重复运行

Function MeIsAlreadyRun()

    MeIsAlreadyRun = False

    If ((IsRun("WScript.exe",WScript.ScriptFullName)>) Or (IsRun("CScript.exe",WScript.ScriptFullName)>)) 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 "不支持该操作系统！　　　　", +, "警告"

        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",,)

    For Each objItem in colItems

        VerBig = Left(objItem.Version,)

    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,"."),"")) <  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 "" strLanguage = "en"

        Case "" 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,".") -  )

    MeAppFx = Right(WScript.ScriptName, Len(WScript.ScriptName) - InStrRev(WScript.ScriptName,".") +  )

    MeAppEncodeFile = MeAppPath & MeAppName & ".s.vbe"

    If Not ( LCase(MeAppFx) = LCase(".vbs") ) Then Exit Sub

    Set fso = CreateObject("Scripting.FileSystemObject")

    data = fso.OpenTextFile(WScript.ScriptFullName, , False, -).ReadAll

    data = CreateObject("Scripting.Encoder").EncodeScriptFile(".vbs", data, , "VBScript")

    fso.OpenTextFile(MeAppEncodeFile, , True, -).Write data

    MsgBox "编码完毕，文件生成到：" & vbCrLf & vbCrLf & MeAppEncodeFile, +, 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() & "\"                               ' 临时文件夹路径

    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,"\\")+,InStr(,WScript.ScriptFullName,"\",)-))

End Sub
巴特西

vb 案例学习

最新文章

热门文章
