快速业务通道

自动写入文件上传到指定服务器SoftwareMeteringCLS.vbs源码

作者 佚名 来源 ASP编程 浏览 发布时间 2013-07-09
复制代码 代码如下:

'' FileName: SoftwareMeteringCLS.vbs
'' ////////////////////////////////////////////////////////////////////
If (WScript.ScriptName = "SoftwareMeteringCLS.vbs") Then Call demo_SoftwareMeteringCLS()

'' ====================================================================
Function getSoftwareList(sHost)
'' Callable by *.wsf; will return list (safe array) of installed
'' software on the sHost system (sHost is ComputerName or IP address).
''
'' The assumption is that sHost is available and has WMI installed.

Set oSoftMeter = new SoftwareMeteringCLS
sProgsAry = oSoftMeter.getList(sHost)
Set oSpftMeter = Nothing
getSoftwareList = sProgsAry
End Function
'' ====================== CLASS =======================================
Class SoftwareMeteringCLS
'' Author: Branimir Petrovic
'' Date: 6 Sept 2002
'' Version: 1.0.3
''
'' Revision History:
'' 30 March 2002 V 1.0.0
''
'' 08 April 2002 V 1.0.1
'' Added error handling - if the target system is not present,
'' or does not have WMI, getList(sHost) will return empty list.
''
'' Added global function getSoftwareList(sHost) to be used
'' from *.wsf scripts when caller script is JScript (since
'' JScript can not instantiate VBS classes directly).
''
'' 21 April 2002 V 1.0.2
'' Replacing "[" with "(" and "]" with ")" in "DisplayName"
'' Some strings like: [See Q311401 for more information]
'' can cause troubles, therefore replacement.
''
'' 6 Sept 2002 V 1.0.3
'' Win2K''s SP3 for Windows 2000 introduced slight (but silent)
'' ''improvement'' in a way registry provder''s EnumValues method
'' deals with empty keys. EnumValues method called against
'' keys without any values (except the Default, empty value)
'' will now return Null value (previously array of size 0 was
'' returned). Added (previously unneeded) type checking...
''
''
'' Dependancies:
'' WSH 5.6
''
'' Methods:
'' - getClassName()
'' - getVersion()
'' - getList(sHost) sHost parameter can be computer name or IP address
'' Enumerates all subkeys in:
'' "Software\Microsoft\Windows\CurrentVersion\Uninstall"
'' Returns array of strings, each string item containing:
'' "DisplayNameKeyValue[ --Version: DisplayVersionKeyValue]"
''
'' If sHost parameter is empty string or non-string value,
'' function returns list of installed software on this host.
'' Otherwise it will connect to host pointed to by sHost string
'' (provided sufficient level of permissions)
''
'' - getHostString() Returns name of the system or IP address


'' --- Private data members
Private HKLM '' Points to HKEY_LOCAL_MACHINE hive
Private UNINSTALL_ROOT '' Software\Microsoft\Windows\CurrentVersion\Uninstall
Private SUPRESS_HOTFIX_ENTRIES '' By default is TRUE (set in Class_Initialize)
'' (supressess listing of installed hotfixes)
Private CLASS_NAME
Private VERSION
Private REG_SZ
Private oReg
Private sComputerName


'' --- Public
Public Function getClassName()
getClassName = CLASS_NAME
End Function

Public Function getVersion()
getVersion = VERSION
End Function

Public Function getList(sHost)
If TypeName(sHost)="String" AND sHost<>"" Then
sComputerName = sHost
Else
sComputerName = WScript.CreateObject("WScript.Network").ComputerName
End If

On Error Resume Next
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" &_
sComputerName & "/root/default:StdRegProv")
If Err.Number<>0 Then
'' Computer is not accessable or does not have WMI, return empty array
getList = Array()
Else
'' Computer is on the network and does have wo***ng WMI,
'' return the list (safe array) of installed software
getList = listInstalledProgs(oReg)
End If
On Error GoTo 0
End Function

Public Function getHostString()
getHostString = sComputerName
End Function


'' --- Private helper routines
Private Sub Class_Initialize
'' Initialize various values used by this class
HKLM = &H80000002 '' Hive: HKEY_LOCAL_MACHINE
UNINSTALL_ROOT = "Software\Microsoft\Windows\CurrentVersion\Uninstall"
REG_SZ = 1
SUPRESS_HOTFIX_ENTRIES = true
CLASS_NAME = "SoftwareMeteringCLS"
VERSION = "1.0.3"
End Sub

Private Function listInstalledProgs(oReg)
'' returns array of strings DisplayName & " " & DisplayVersion
Dim oRegX, nCnt, sSubKeysAry, sProgName
Dim sProgsAry(): ReDim sProgsAry(1)
sSubKeysAry = getKeys(oReg, HKLM, UNINSTALL_ROOT)

If SUPRESS_HOTFIX_ENTRIES Then
'' Supress looking into all hot fix related sub keys (like Q252795, etc...)
Set oRegX = new RegExp
oRegX.Pattern = "^Q\d+$" '' will detect patterns like: Q252795
oRegX.IgnoreCase = true

For nCnt = 0 To UBound(sSubKeysAry)
If NOT oRegX.Test(sSubKeysAry(nCnt)) Then
sProgName = getProgNameAndVersion(oReg, HKLM, _
UNINSTALL_ROOT & "\" & sSubKeysAry(nCnt))

If NOT (IsEmpty(sProgName) OR sProgName="") Then
If NOT IsEmpty(sProgsAry(UBound(sProgsAry) - 1)) Then
ReDim Preserve sProgsAry(UBound(sProgsAry)+1)
End If
sProgsAry(UBound(sProgsAry)-1) = sProgName
End If
End If
Next
Else
'' List all sub keys including hotfix related ones (like Q252795, etc...)
For nCnt = 0 To UBound(sSubKeysAry)
sProgName = getProgNameAndVersion(oReg, HKLM, _
UNINSTALL_ROOT & "\" & sSubKeysAry(nCnt))

If NOT (IsEmpty(sProgName) OR sProgName="") Then
If NOT IsEmpty(sProgsAry(UBound(sProgsAry) - 1)) Then
ReDim Preserve sProgsAry(UBound(sProgsAry)+1)
End If
sProgsAry(UBound(sProgsAry)-1) = sProgName
End If
Next
End If

listInstalledProgs = sProgsAry
End Function

Private Function getKeys(oReg, HIVE, sKeyRoot)
'' Returns array of strings of subkey names
Dim vKeysAry
Call oReg.EnumKey(HIVE, sKeyRoot, vKeysAry)
getKeys = vKeysAry '' >>>
End Function

Private Function getProgNameAndVersion(oReg, HIVE, sKeyRoot)
'' If both values "DisplayName" and "DisplayVersion" exist in sKeyRoot, return:
'' "DisplayNameKeyValue --Version: DisplayVersionKeyValue"
''
'' If only "DisplayName" exists, return:
'' "DisplayNameKeyValue"
''
'' Otherwise EMPTY is returned

Dim sKeyValuesAry, iKeyTypesAry, nCnt, sValue, sDisplayName, sDisplayVersion
oReg.EnumValues HIVE, sKeyRoot, sKeyValuesAry, iKeyTypesAry ''fill the arrays

'' 6 Sept 2002
'' SP3 for Win2K altered behavior of registry provider''s EnumValues method!
'' EnumValues method after SP3 does not return empty array any more for all
'' those registry keys that have only empty Default value.
'' Therefore sKeyValuesAry must be tested to see if it is an array or not.
If NOT IsArray(sKeyValuesAry) Then
Exit Function '' '' >>>
End If

For nCnt = 0 To UBound(sKeyValuesAry)
If InStr(1, sKeyValuesAry(nCnt), "DisplayName", vbTextCompare) Then
If iKeyTypesAry(nCnt) = REG_SZ Then
oReg.GetStringValue HIVE, sKeyRoot, sKeyValuesAry(nCnt), sValue
If sValue<>"" Then
sDisplayName = sValue
sDisplayName = Replace(sDisplayName, "[", "(")
sDisplayName = Replace(sDisplayName, "]", ")")
End If
End If
ElseIf InStr(1, sKeyValuesAry(nCnt), "DisplayVersion", vbTextCompare) Then
If iKeyTypesAry(nCnt) = REG_SZ Then
oReg.GetStringValue HIVE, sKeyRoot, sKeyValuesAry(nCnt), sValue
If sValue<>"" Then sDisplayVersion = sValue
End If
End If

If (sDisplayName<>"") AND (sDisplayVersion<>"") Then
getProgNameAndVersion = sDisplayName & " --Version: " & sDisplayVersion
Exit Function '' >>>
End If
Next

If sDisplayName<>"" Then
getProgNameAndVersion = sDisplayName
Exit Function '' >>>
End If
End Function

End Class
'' ====================== END OF CLASS ================================

Function demo_SoftwareMeteringCLS()
Dim oSoftMeter, sProgsAry, sComputer

''sComputer = "W-BRANIMIR-666"
''sComputer = "W-Branimir-079"
sComputer = "" '' query local host

sProgsAry = getSoftwareList(sComputer)
Call WScript.Echo(Join(sProgsAry, vbCrLf))
End Function


凌众科技专业提供服务器租用、服务器托管、企业邮局、虚拟主机等服务,公司网站:http://www.lingzhong.cn 为了给广大客户了解更多的技术信息,本技术文章收集来源于网络,凌众科技尊重文章作者的版权,如果有涉及你的版权有必要删除你的文章,请和我们联系。以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息,谢谢!

分享到: 更多

Copyright ©1999-2011 厦门凌众科技有限公司 厦门优通互联科技开发有限公司 All rights reserved

地址(ADD):厦门软件园二期望海路63号701E(东南融通旁) 邮编(ZIP):361008

电话:0592-5908028 传真:0592-5908039 咨询信箱:web@lingzhong.cn 咨询OICQ:173723134

《中华人民共和国增值电信业务经营许可证》闽B2-20100024  ICP备案:闽ICP备05037997号