Running a vbscript that is supposed to complete series of process checks and write the results to a text file. The script runs fine on windows 2003 server but on the new Windows 2008 R2 get the following error:
Line: 409
Char: 6
Error: Invalid procedure call or argument
Code: 800A0005
Source: Microsoft VBScript runtime error
Here is the line of code with the error:
Line: 409
Char: 6
Error: Invalid procedure call or argument
Code: 800A0005
Source: Microsoft VBScript runtime error
Here is the line of code with the error:
Code:
objTextFile.WriteLine(status & " " & FormatDate(Now(), "%a %d %H:%M:%S %Y") & " " & host & vbCrLf & message)
Here is the entire script
<job id="BitechCheck">
<script language="VBScript" src="Config.vbs"/>
<script language="VBScript" src="Registry.vbs"/>
<script language="VBScript" src="Process.vbs"/>
<script language="VBScript" src="MSMQTests.vbs"/>
<script language="VBScript" src="Computer.vbs"/>
<script language="VBScript">
Option Explicit
'On Error Resume Next
Function outputTag(mytest, state, mesg)
outputTag = " <output test=""" & mytest & """ state=""" & state & """>" & vbCrLf & mesg & " </output>" & vbCrLf
End Function
Function BuildSimpleMessage(mesg)
BuildSimpleMessage = " <SM>" & mesg & "</SM>" & vbCrLf
End Function
Function BuildMultiMessage(ByRef mmDict)
Dim strRow, row, key
strRow = " <MM>" & vbCrLf
For Each row In mmDict.Keys
If mmDict.Item(row).Exists("params") Then
strRow = strRow & " <row index=""" & row & """" & mmDict.Item(row).Item("params") & ">" & vbCrLf
Else
strRow = strRow & " <row index=""" & row & """>" & vbCrLf
End If
For Each key In mmDict.Item(row).Keys
If Left(key, 3) = "col" Then
If mmDict.Item(row).Item(key).Exists("params") Then
strRow = strRow & " <col " & mmDict.Item(row).Item(key).Item("params") & ">" & mmDict.Item(row).Item(key).Item("data") & "</col>" & vbCrLf
Else
strRow = strRow & " <col>" & mmDict.Item(row).Item(key).Item("data") & "</col>" & vbCrLf
End If
End If
Next
strRow = strRow & " </row>" & vbCrLf
Next
strRow = strRow & " </MM>" & vbCrLf
BuildMultiMessage = strRow
End Function
Function BitechLoggingInfo(ByRef objRegistry, ByRef myconfig)
Dim dwEnabled, strResult, mmDict, module, rk
Dim objModuleDict
rk = Split(myconfig.TestParam("Tracing", "rkEnable"),",")
'WScript.Echo ("Received: " & rk(0) & "-" & rk(1) & "-" & rk(2))
If Not(objRegistry.DoesKeyExist(rk(0),rk(1),rk(2))) Then
strResult = outputTag("Bi-Tech TRACING", "green", BuildSimpleMessage("Tracing is Disabled"))
Else
dwEnabled = objRegistry.ReadDWORDVal(rk(0), rk(1), rk(2))
If dwEnabled > 0 Then
strResult = outputTag("Bi-Tech TRACING", "yellow", BuildSimpleMessage("Tracing is Enabled"))
' Get all Module subkeys that are enabled (ie > 0)
' Allowable types for GetSubValuesBy Type Function REG_SZ, REG_EXPAND_SZ, REG_BINARY, REG_DWORD, REG_MULTI_SZ
rk = Split(myconfig.TestParam("Tracing", "rkModuleSubKey"),",")
'WScript.Echo ("Received: " & rk(0) & "-" & rk(1))
Set objModuleDict = objRegistry.GetSubValuesByType(rk(0),rk(1),"REG_DWORD")
Set mmDict = CreateObject("Scripting.Dictionary")
mmDict.Add "Header", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col1").Add "data", "Module"
mmDict.Item("Header").Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col2").Add "data", "Setting"
Dim i: i=0
For Each module In objModuleDict.Keys
If objModuleDict.Item(module) > 0 Then
'WScript.Echo "HERE " & i & " MoD " & module
mmDict.Add i, CreateObject("Scripting.Dictionary")
mmDict.Item(i).Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item("col1").Add "data", module
mmDict.Item(i).Item("col1").Add "params", "state=""yellow"""
mmDict.Item(i).Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item("col2").Add "data", objModuleDict.Item(module)
mmDict.Item(i).Item("col2").Add "params", "state=""yellow"""
i = i+1
End If
Next
strResult = strResult & outputTag("Enabled Modules", "yellow", BuildMultiMessage(mmDict))
Else
strResult = outputTag("Bi-Tech TRACING", "green", BuildSimpleMessage("Tracing is Disabled"))
End If
End If
BitechLoggingInfo = strResult
End Function
Function BitechVersionInfo(ByRef objRegistry, ByRef myconfig)
Dim expectedVersion, version, status, app, rk, mmDict
rk = Split(myconfig.TestParam("Version", "rkVersion"),",")
'Every 7i server should have screens at the very least
status = "green"
If Not(objRegistry.DoesKeyExist(rk(0),rk(1),rk(2))) Then
BitechVersionInfo = outputTag("Version Info", status, BuildSimpleMessage("This is not a properly configured 7i server"))
Exit Function
End If
expectedVersion = objRegistry.ReadStrVal(rk(0),rk(1),rk(2))
Set mmDict = CreateObject("Scripting.Dictionary")
mmDict.Add "Header", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col1").Add "data", "PRODUCT"
mmDict.Item("Header").Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col2").Add "data", "VERSION"
Dim i : i=0
For Each app In (myconfig.BitechApps())
rk = Split(myconfig.TestParam("Version", "rkAppVersion"),",")
'WScript.Echo "rkAppVersion: " & rk(0) & "-" & rk(1) & app & "-" & rk(2)
If objRegistry.DoesKeyExist(rk(0),rk(1) & app, rk(2)) Then
version = objRegistry.ReadStrVal(rk(0),rk(1) & app, rk(2))
'WScript.Echo "HERE " & i & " App: " & app & " Version: " & version
mmDict.Add i, CreateObject("Scripting.Dictionary")
mmDict.Item(i).Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item("col1").Add "data", app
mmDict.Item(i).Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item("col2").Add "data", version
If (version = expectedVersion) OR (app = "OPENLINK") Then
mmDict.Item(i).Item("col1").Add "params", "state=""green"""
mmDict.Item(i).Item("col2").Add "params", "state=""green"""
Else
status = "red"
mmDict.Item(i).Item("col1").Add "params", "state=""red"""
mmDict.Item(i).Item("col2").Add "params", "state=""red"""
End If
i = i+1
End If
Next
BitechVersionInfo = outputTag("Version Info", status, BuildMultiMessage(mmDict))
End Function
' Later could add a function in XML_Handler to do a Post like this
' and reduce the number of lines and check in this call
' Call might be xml_cls.PostXML(url, xmlRequest, recvTimeout, errArray(timeout_err, communication_err, resp_parse_err))
Function BitechLogin_Check(ByRef myconfig)
Dim xmlRequest, xmlHTTP, xmlDoc, respNode
Dim receiveTimeout
Dim sReq : sReq = myconfig.TestParam("Login", "xmlconnect")
set xmlRequest = createObject("MSXML2.DOMDocument")
xmlRequest.async = false
If xmlRequest.loadXML(sReq) Then
set xmlHTTP=createObject("MSXML2.ServerXMLHTTP")
xmlHTTP.open "POST","http://localhost/ifas7/isapi/btwebrqb.dll", True
xmlHTTP.send(xmlRequest)
'Turn off errors because don't want script to die if response is bad.
On Error Resume Next
'Wait for a response for a configurable amount of time
receiveTimeout = myconfig.TestParam("Login", "receiveTimeout")
If xmlHTTP.readyState <> 4 then
Call xmlHTTP.waitForResponse(receiveTimeout)
End If
'Check for timeout error
If Err.Number <> 0 then
BitechLogin_Check = outputTag("Login Test", "red", BuildSimpleMessage("Error: Login Timeout reached"))
Else
If (xmlHTTP.readyState <> 4) Or (xmlHTTP.Status <> 200) Then
BitechLogin_Check = outputTag("Login Test", "red", BuildSimpleMessage("Error: Problem communicating with server: XML Status: " & xmlHTTP.readyState & " HTTP status: " & xmlHTTP.Status))
'Abort the XMLHttp request
xmlHTTP.Abort
Else
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.loadXML xmlHTTP.responseText
If xmlDoc.parseError.errorCode <> 0 Then
BitechLogin_Check = outputTag("Login Test", "red", BuildSimpleMessage("Could not parse login response, 7i probably down!"))
Else 'Got a response
Set respNode = xmlDoc.getElementsByTagName("Response")(0).firstChild
If respNode.nodeName = "LoginError" Then
BitechLogin_Check = outputTag("Login Test", "red", BuildSimpleMessage("Login Error: " & respNode.firstChild.nodeValue))
Else
BitechLogin_Check = outputTag("Login Test", "green", BuildSimpleMessage("Login Successful"))
End If
End If
End If
End If
Else
BitechLogin_Check = outputTag("Login Test", "red", BuildSimpleMessage("Could not load login test XML"))
End If
End Function
Function MSMQMesgTest(ByRef msmqt, ByRef myconfig)
Dim mmDict, queue, status
Set mmDict = CreateObject("Scripting.Dictionary")
mmDict.Add "Header", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col1").Add "data", "Queue"
mmDict.Item("Header").Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col2").Add "data", "Message Count"
mmDict.Item("Header").Add "col3", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col3").Add "data", "Queue Bytes"
mmDict.Item("Header").Add "col4", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col4").Add "data", "Quota KBytes"
Dim i : i = 0
For Each queue In msmqt.GetPrivateQueues()
msmqt.QueueName = queue
mmDict.Add i, CreateObject("Scripting.Dictionary")
mmDict.Item(i).Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item("col1").Add "data", queue
mmDict.Item(i).Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Add "col3", CreateObject("Scripting.Dictionary")
mmDict.Item(i).Add "col4", CreateObject("Scripting.Dictionary")
If Err.Number <> 0 Then
If Err.Number = -1072824316 Then
' Later might want to actually check which problem exists
' Does the queue not exist, or is it not open?
' Most likely not open, or it would not get to this point.
mmDict.Item(i).Item("col2").Add "data", Err.Description
mmDict.Item(i).Item("col2").Add "params", "state=""green"""
mmDict.Item(i).Item("col3").Add "data", "Error"
mmDict.Item(i).Item("col3").Add "params", "state=""green"""
mmDict.Item(i).Item("col4").Add "data", "Error"
mmDict.Item(i).Item("col4").Add "params", "state=""green"""
status = "green"
Else
mmDict.Item(i).Item("col2").Add "data", Err.Description
mmDict.Item(i).Item("col2").Add "params", "state=""yellow"""
mmDict.Item(i).Item("col3").Add "data", "Error"
mmDict.Item(i).Item("col3").Add "params", "state=""yellow"""
mmDict.Item(i).Item("col4").Add "data", "Error"
mmDict.Item(i).Item("col4").Add "params", "state=""yellow"""
status = "yellow"
End If
Err.Clear
Else
Dim qcount : qcount = msmqt.GetQueueMsgCount()
mmDict.Item(i).Item("col2").Add "data", qcount
Dim msgy : msgy = 0 + myconfig.TestParam("MSMQ", "msgcounty")
Dim msgr : msgr = 0 + myconfig.TestParam("MSMQ", "msgcountr")
'Test message counts
If qcount > msgr Then
mmDict.Item(i).Item("col2").Add "params", "state=""red"""
status = "red"
Else
If qcount > msgy Then
mmDict.Item(i).Item("col2").Add "params", "state=""yellow"""
status = "yellow"
Else
mmDict.Item(i).Item("col2").Add "params", "state=""green"""
status = "green"
End If
End If
Dim qbytes : qbytes = CLng(msmqt.GetQueueBytes())
mmDict.Item(i).Item("col3").Add "data", CStr(msmqt.GetQueueBytes())
msgy = CLng( myconfig.TestParam("MSMQ", "msgbytesy") )
msgr = CLng( myconfig.TestParam("MSMQ", "msgbytesr") )
'Test Byte sizes
If qbytes > msgr Then
mmDict.Item(i).Item("col3").Add "params", "state=""red"""
status = "red"
Else
If qbytes > msgy Then
mmDict.Item(i).Item("col3").Add "params", "state=""yellow"""
status = "yellow"
Else
mmDict.Item(i).Item("col3").Add "params", "state=""green"""
status = "green"
End If
End If
Dim qquota : qquota = CLng(msmqt.GetQueueQuota()) * 1024
mmDict.Item(i).Item("col4").Add "data", CStr(msmqt.GetQueueQuota())
msgy = CLng( myconfig.TestParam("MSMQ", "msgquotay") )
msgr = CLng( myconfig.TestParam("MSMQ", "msgquotar") )
'Test if quota was violated
' msgr and msgy hold the number of bytes below the qquota threshold
' that triggers a red or yellow alert. For example, if the queue quota
' is 4096 bytes qbytes would have to be grater then 4096 - msgr to trigger a red alert.
If (qbytes > (qquota - msgr)) And (qquota <> -1024) Then
mmDict.Item(i).Item("col4").Add "params", "state=""red"""
status = "red"
Else
If (qbytes > (qquota - msgy)) And (qquota <> -1024) Then
mmDict.Item(i).Item("col4").Add "params", "state=""yellow"""
status = "yellow"
Else
mmDict.Item(i).Item("col4").Add "params", "state=""green"""
status = "green"
End If
End If
End If
i = i + 1
Next
MSMQMesgTest = outputTag("MSMQ Count", status, BuildMultiMessage(mmDict))
End Function
Function BitechWFp_check(ByRef objProcess, ByRef myconfig)
Dim confignum : confignum = myconfig.TestParam("WFproc", "numprocs")
'WScript.Echo "WF processes: " & myconfig.TestParam("WFproc", "wfengproc") & "-" & myconfig.TestParam("WFproc", "wfsvcproc")
BitechWFp_check = (objProcess.IsProcessActive(myconfig.TestParam("WFproc", "wfengproc"), confignum, "=") AND _
objProcess.IsProcessActive(myconfig.TestParam("WFproc", "wfsvcproc"), confignum, "="))
End Function
Function Bitech7ip_check(ByRef objProcess, ByRef myconfig)
'WScript.Echo "BTQMH processes: " & myconfig.TestParam("BTMQHproc", "btmqhproc")
Bitech7ip_check = objProcess.IsProcessActive(myconfig.TestParam("BTMQHproc", "btmqhproc"), myconfig.TestParam("BTMQHproc", "numprocs"), "=")
End Function
Function BitechCDDp_check(ByRef objProcess, ByRef objRegistry, ByRef myconfig)
Dim numCDD, rk
rk = Split(myconfig.TestParam("CDDproc", "rkCDDMax"),",")
'WScript.Echo "rkCDDMax: " & rk(0) & "-" & rk(1) & "-" & rk(2)
If objRegistry.DoesKeyExist(rk(0),rk(1),rk(2)) Then
numCDD = objRegistry.ReadDWORDVal(rk(0),rk(1),rk(2))
'WScript.Echo "Key existed: " & numCDD
'WScript.Echo "CDD proc: " & myconfig.TestParam("CDDproc", "cddproc")
'BitechCDDp_check = objProcess.IsProcessActive(myconfig.TestParam("CDDproc", "cddproc"), numCDD, ">=")
Else
'If the key isn't defined typically 4 is the default max instances
'BitechCDDp_check = objProcess.IsProcessActive(myconfig.TestParam("CDDproc", "cddproc"), myconfig.TestParam("CDDproc", "numprocs"), ">=")
numCDD = myconfig.TestParam("CDDproc", "numprocs")
End If
BitechCDDp_check = 0
If objProcess.IsProcessActive(myconfig.TestParam("CDDproc", "cddproc"), numCDD * myconfig.TestParam("CDDproc", "numprocsy"), "<=") Then
BitechCDDp_check = 1
End If
If objProcess.IsProcessActive(myconfig.TestParam("CDDproc", "cddproc"), numCDD * myconfig.TestParam("CDDproc", "numprocsr"), "<=") Then
BitechCDDp_check = 2
End If
End Function
Sub FillmmDict(ByRef objProcess, ByRef mmDict, col, myfunction, params, thresholds)
Dim state
Dim pt, i
Dim ptempArr: ptempArr = Eval("objProcess." & myfunction & "(" & params & ")")
If Not(IsNull(ptempArr)) Then
i = 0
For Each pt In ptempArr
state = "green"
If Not(IsNull(thresholds)) Then
If pt >= (0 + thresholds.Item("YELLOW")) Then
state = "yellow"
End If
If pt >= (0 + thresholds.Item("RED")) Then
state = "red"
End If
End If
If Not(mmDict.Exists(i)) Then
mmDict.Add i, CreateObject("Scripting.Dictionary")
End If
mmDict.Item(i).Add col, CreateObject("Scripting.Dictionary")
mmDict.Item(i).Item(col).Add "data", pt
mmDict.Item(i).Item(col).Add "params", "state=""" & state & """"
i = i + 1
Next
End If
End Sub
Sub CreateBBLog(host, status, strDirectory, strFile_in, message)
Dim objFSO, objFolder, objShell, objTextFile, objFile
Dim strFile
'Temp file
strFile = "tmpfile.txt"
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
'WScript.Echo "Just created " & strDirectory
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
'Wscript.Echo "Just created " & strDirectory & strFile
End If
set objFile = nothing
set objFolder = nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
'Const ForReading = 1
Const ForWriting= 2
'Const ForAppending = 8
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, ForWriting, True)
' Writes strText every time you run this VBScript
objTextFile.WriteLine(status & " " & FormatDate(Now(), "%a %d %H:%M:%S %Y") & " " & host & vbCrLf & message)
objTextFile.Close
' Bonus or cosmetic section to launch explorer to check file
'If err.number = vbEmpty then
' Set objShell = CreateObject("WScript.Shell")
' objShell.run ("Explorer" &" " & strDirectory & "\" )
'Else
' WScript.echo "VBScript Error: " & err.number
'End If
'Rename File
'WScript.Echo "Renaming " & (strDirectory & strFile) & " to " & (strDirectory & strFile_in)
objFSO.MoveFile (strDirectory & strFile), (strDirectory & strFile_in)
End Sub
'%m Month as a decimal no. 02
'%b Abbreviated month name Feb
'%B Full month name February
'%d Day of the month 23
'%j Day of the year 54
'%y Year without century 98
'%Y Year with century 1998
'%w Weekday as integer 5 (0 is Sunday)
'%a Abbreviated day name Fri
'%A Weekday Name Friday
'%I Hour in 12 hour format 12
'%H Hour in 24 hour format 24
'%M Minute as an integer 01
'%S Second as an integer 55
'%P AM/PM Indicator PM
'%% Actual Percent sign %%
Function FormatDate (strDate, strFormat)
Dim intPosItem, intHourPart, strHourPart, strMinutePart, strSecondPart, strAMPM, dp
If not IsDate(strDate) Then
FormatDate = strDate
Exit Function
End If
intPosItem = Instr(strFormat, "%m")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
DatePart("m",strDate) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%m")
Loop
intPosItem = Instr(strFormat, "%b")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
MonthName(DatePart("m",strDate),True) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%b")
Loop
intPosItem = Instr(strFormat, "%B")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
MonthName(DatePart("m",strDate),False) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%B")
Loop
intPosItem = Instr(strFormat, "%d")
Do While intPosItem > 0
dp = DatePart("d",strDate)
If dp < 10 Then dp = "0" & dp
strFormat = Left(strFormat, intPosItem-1) & _
dp & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%d")
Loop
intPosItem = Instr(strFormat, "%j")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
DatePart("y",strDate) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%j")
Loop
intPosItem = Instr(strFormat, "%y")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
Right(DatePart("yyyy",strDate),2) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%y")
Loop
intPosItem = Instr(strFormat, "%Y")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
DatePart("yyyy",strDate) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%Y")
Loop
intPosItem = Instr(strFormat, "%w")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
DatePart("w",strDate,1) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%w")
Loop
intPosItem = Instr(strFormat, "%a")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
WeekDayName(DatePart("w",strDate,1),True) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%a")
Loop
intPosItem = Instr(strFormat, "%A")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & _
WeekDayName(DatePart("w",strDate,1),False) & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%A")
Loop
intPosItem = Instr(strFormat, "%I")
Do While intPosItem > 0
intHourPart = DatePart("h",strDate) mod 12
if intHourPart = 0 then intHourPart = 12
strFormat = Left(strFormat, intPosItem-1) & _
intHourPart & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%I")
Loop
intPosItem = Instr(strFormat, "%H")
Do While intPosItem > 0
strHourPart = DatePart("h",strDate)
if strHourPart < 10 Then strHourPart = "0" & strHourPart
strFormat = Left(strFormat, intPosItem-1) & _
strHourPart & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%H")
Loop
intPosItem = Instr(strFormat, "%M")
Do While intPosItem > 0
strMinutePart = DatePart("n",strDate)
if strMinutePart < 10 then strMinutePart = "0" & strMinutePart
strFormat = Left(strFormat, intPosItem-1) & _
strMinutePart & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%M")
Loop
intPosItem = Instr(strFormat, "%S")
Do While intPosItem > 0
strSecondPart = DatePart("s",strDate)
if strSecondPart < 10 then strSecondPart = "0" & strSecondPart
strFormat = Left(strFormat, intPosItem-1) & _
strSecondPart & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%S")
Loop
intPosItem = Instr(strFormat, "%P")
Do While intPosItem > 0
if DatePart("h",strDate) >= 12 then
strAMPM = "PM"
Else
strAMPM = "AM"
End If
strFormat = Left(strFormat, intPosItem-1) & _
strAMPM & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%P")
Loop
intPosItem = Instr(strFormat, "%%")
Do While intPosItem > 0
strFormat = Left(strFormat, intPosItem-1) & "%" & _
Right(strFormat, Len(strFormat) - (intPosItem + 1))
intPosItem = Instr(strFormat, "%%")
Loop
FormatDate = strFormat
End Function
Function Reformat(vTemp)
'This function is used to replace certain chars that need to
'be converted
If Instr(1,vtemp,"&amp;apos;") Then
'Replace fixes every item in the string
vTemp = Replace(vTemp,"&amp;apos;","'")
'The string "&amp;apos;" must be searched for b/c the replacement
'of an apostrophe in XML is &apos;, but this is not recognized
'as valid HTML so it gets interpreted as an ampersand + apos;,
'and doesn't render properly
End If
If Instr(1,vTemp,"&amp;lt;") Then
vTemp = Replace(vTemp,"&amp;lt;","&lt;")
End If
If Instr(1,vTemp,"&amp;gt;") Then
vTemp = Replace(vTemp,"&amp;gt;","&gt;")
End If
If Instr(1,vTemp,"&amp;amp;") Then
vTemp = Replace(vTemp,"&amp;amp;","&amp;")
End If
If Instr(1,vTemp,"&amp;quot;") Then
vTemp = Replace(vTemp,"&amp;quot;","&quot;")
End If
Reformat = vTemp
End Function
'Main Driver of Script
Sub Main()
Dim strIFAScheck, status
Dim strComputer, objWMIService, objProcess, objRegistry, myconfig, mycomputerclass
Dim objDictionary, mmDict
'Set the computer name from the config file
Set myconfig = New Config
myconfig.ConfigFile = "configuration.xml"
strComputer = myconfig.Hostname
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
' Can not pass parameters in constructor, so create and set right after
Set objProcess = New Process
objProcess.WMIservice = objWMIService
Set objRegistry = New Registry
Set objDictionary = CreateObject("Scripting.Dictionary")
strIFAScheck = ""
strIFAScheck = "<div id=""transformedxml"">" & vbCrLf
strIFAScheck = strIFAScheck & "<form name=""xmlform"" style=""display:none;visibility:hidden"">" & vbCrLf
strIFAScheck = strIFAScheck & "<textarea name=""xmltext"">" & vbCrLf
strIFAScheck = strIFAScheck & "<response host=""" & myconfig.Hostname & """ app=""" & myconfig.Checkname & """>" & vbCrLf
'Tracing Info Check
If myconfig.TestOn("Tracing") Then
strIFAScheck = strIFAScheck & BitechLoggingInfo(objRegistry, myconfig)
End If
'Version Info Check
If myconfig.TestOn("Version") Then
strIFAScheck = strIFAScheck & BitechVersionInfo(objRegistry, myconfig)
End If
'Check for functional CDD service
If myconfig.TestOn("CDDproc") Then
Dim mycheck : mycheck = BitechCDDp_check(objProcess, objRegistry, myconfig)
If mycheck = 0 Then
strIFAScheck = strIFAScheck & outputTag("Max CDD Process Check", "green", BuildSimpleMessage("CDD Process within thresholds"))
End If
If mycheck = 1 Then
strIFAScheck = strIFAScheck & outputTag("Max CDD Process Check", "yellow", BuildSimpleMessage("More then " & myconfig.TestParam("CDDproc", "numprocsy") & "X CDD processes active."))
End If
If mycheck = 2 Then
strIFAScheck = strIFAScheck & outputTag("Max CDD Process Check", "red", BuildSimpleMessage("More then " & myconfig.TestParam("CDDproc", "numprocsr") & "X CDD processes active."))
End If
End If
'Check for functional Workflow service
If myconfig.TestOn("WFproc") Then
If Not(BitechWFp_check(objProcess, myconfig)) Then
strIFAScheck = strIFAScheck & outputTag("Workflow Process Check", "red", BuildSimpleMessage("Workflow Service Malfunction"))
Else
strIFAScheck = strIFAScheck & outputTag("Workflow Process Check", "green", BuildSimpleMessage("Workflow Service is Stable"))
End If
End If
'Check the login to btwebrqb
If myconfig.TestOn("Login") Then
strIFAScheck = strIFAScheck & BitechLogin_Check(myconfig)
End If
'Check Message Queue count
If myconfig.TestOn("MSMQ") Then
Dim msmqt
Set msmqt = New MSMQTests
msmqt.MachineName = myconfig.Hostname
strIFAScheck = strIFAScheck & MSMQMesgTest(msmqt, myconfig)
End If
'Check for functional btqmhosts
If myconfig.TestOn("BTMQHproc") Then
If Not(Bitech7ip_check(objProcess, myconfig)) Then
strIFAScheck = strIFAScheck & outputTag("BTQMHost Process Check", "red", BuildSimpleMessage("BTQMHost(s) Process Malfunction"))
Else
strIFAScheck = strIFAScheck & outputTag("BTQMHost Process Check", "green", BuildSimpleMessage("BTQMHost(s) Process(es) are Stable"))
End If
Set mmDict = CreateObject("Scripting.Dictionary")
mmDict.Add "Header", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Add "col1", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col1").Add "data", "Proc ID"
mmDict.Item("Header").Add "col2", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col2").Add "data", "~ CPU Time ~"
mmDict.Item("Header").Add "col3", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col3").Add "data", "~ Mem (KB) ~"
mmDict.Item("Header").Add "col4", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col4").Add "data", "~ Page File ~"
'mmDict.Item("Header").Add "col5", CreateObject("Scripting.Dictionary")
'mmDict.Item("Header").Item("col5").Add "data", "~ Page Faults ~"
mmDict.Item("Header").Add "col5", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col5").Add "data", "~ Thrashing ~"
mmDict.Item("Header").Add "col6", CreateObject("Scripting.Dictionary")
mmDict.Item("Header").Item("col6").Add "data", "~ Threads ~"
'Begin BTQMHosts table
' When passing strings you must surround them with single quotes as done below
Dim btmqexe : btmqexe = """" & myconfig.TestParam("BTMQHproc", "btmqhproc") & """"
Call FillmmDict(objProcess, mmDict, "col1", "GetProcessID", btmqexe, null)
Call FillmmDict(objProcess, mmDict, "col2", "GetCPUTime", btmqexe, null)
objDictionary.Add "YELLOW", myconfig.TestParam("BTMQHproc", "memkby")
objDictionary.Add "RED", myconfig.TestParam("BTMQHproc", "memkbr")
Call FillmmDict(objProcess, mmDict, "col3", "GetMemUsage", btmqexe, objDictionary)
objDictionary.RemoveAll
objDictionary.Add "YELLOW", myconfig.TestParam("BTMQHproc", "pagefiley")
objDictionary.Add "RED", myconfig.TestParam("BTMQHproc", "pagefiler")
Call FillmmDict(objProcess, mmDict, "col4", "GetPageFileUsage", btmqexe, objDictionary)
objDictionary.RemoveAll
'objDictionary.Add "YELLOW", myconfig.TestParam("BTMQHproc", "pagefaultsy")
'objDictionary.Add "RED", myconfig.TestParam("BTMQHproc", "pagefaultsr")
'Call FillmmDict(objProcess, mmDict, "col5", "GetPageFaults", btmqexe, objDictionary)
'objDictionary.RemoveAll
Set mycomputerclass = New Computer
mycomputerclass.WMIservice = objWMIService
Dim thrashparams : thrashparams = btmqexe & "," & mycomputerclass.GetAvailableMemory()
objDictionary.Add "YELLOW", 1
objDictionary.Add "RED", 1
Call FillmmDict(objProcess, mmDict, "col5", "GetThrashingResults", thrashparams, objDictionary)
objDictionary.RemoveAll
objDictionary.Add "YELLOW", myconfig.TestParam("BTMQHproc", "threadsy")
objDictionary.Add "RED", myconfig.TestParam("BTMQHproc", "threadsr")
Call FillmmDict(objProcess, mmDict, "col6", "GetThreadCount", btmqexe , objDictionary)
objDictionary.RemoveAll
' End BTQMHosts table
End If
strIFAScheck = strIFAScheck & outputTag("BTQMHosts", "", BuildMultiMessage(mmDict))
strIFAScheck = strIFAScheck & "</response>" & vbCrLf
strIFAScheck = strIFAScheck & "</textarea>" & vbCrLf
strIFAScheck = strIFAScheck & "</form>" & vbCrLf
strIFAScheck = strIFAScheck & "</div>"
' Check Alarms and write log
status = "green"
If Instr(strIFAScheck, "state=""yellow""") Then status = "yellow"
If Instr(strIFAScheck, "state=""red""") Then status = "red"
Call CreateBBLog(myconfig.Hostname, status, myconfig.LogPath, myconfig.Checkname, strIFAScheck)
End Sub
Call Main()
</script>
</job>