自动写入文件上传到指定服务器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 为了给广大客户了解更多的技术信息,本技术文章收集来源于网络,凌众科技尊重文章作者的版权,如果有涉及你的版权有必要删除你的文章,请和我们联系。以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息,谢谢! |
你可能对下面的文章感兴趣
上一篇: vbs fso跨盘移动文件夹的怪问题下一篇: XorEncode的vbs实现代码
关于自动写入文件上传到指定服务器SoftwareMeteringCLS.vbs源码的所有评论