<%
Option Explicit
'Purpose: Displays all queues on all computers in a nt-domain.
' Look at the code. It was too much work to remove all
' german comments and a lot of not public company stuff.
' I hope, I have removed it all.
' You must specify an user with administrative rights
' to get the code running on queues, where only admins
' have rights!!
' After making all the changes above, I was no longer
' able to test the code.
' You must apply your own CSS style sheets, see the HTML header
' in the code.
'Parameters: QueryString("Dom") must contain the domain name.
'GLOBALs
'Apply username and password here!
Const gcStrUser = "xyz"
Const gcStrPWD = "xyz"
Dim lBolAppDebug
'INITs
lBolAppDebug = False 'Debug switch.
Server.ScriptTimeout = 600 'Give him ten (10) minutes for remote domains!
'This was from my include file:
'Name: NTLMAuth.inc
'Reason: Force NTLM authorization:
If Request.ServerVariables("LOGON_USER") = "" Then
Response.Status = "401 access denied"
'Response.AddHeader "WWW-Authenticate", "NTLM"
Response.Flush
Response.End
End If
'Name: QueueShow2.asp
'Function: Lists all print jobs on all computers in a given domain. Therefore,
' at first the ADS domain object is enumerated with filter set to
' "computer". Then each computer object is enumerated with filter
' set to "PrintQueue".
'Remark: There is currently no error handling!
Function strTabIndent(ByVal lngNrOfTabs)
'Function: Returns a string with a parametrized number of TABs .
' It's naturally not usefule with HTML, but the original
' code comes from WSH.
Dim strTemp
Dim i
For i = 1 To lngNrOfTabs
strTemp = strTemp & vbTab
Next
strTabIndent = strTemp
End Function
Function strBGColor(ByVal aNamedColor)
'Function: Returns a "style=" string, containing the color given by parameter.
strBGColor = "style=" & Chr(34) & "background-color: " & aNamedColor & Chr(34)
End Function
Sub WriteJobProperties(ByVal aryStrJobProps, ByVal lngAryIndex, ByVal lngNrLeadingTabs, ByVal strParaColor)
'Function: Writes all properties of a print job from an array to a HTML table row.
' The table row itself is handled outside.
Dim i 'Counter for the status flags properties.
Dim aryStrFlagValues 'Array for the values itself.
PutCon strTabIndent(lngNrLeadingTabs) & "
" & vbNewLine
If aryStrJobProps(8, lngAryIndex) > 0 Then
PutCon strTabIndent(lngNrLeadingTabs) & "
"
aryStrFlagValues = Split(strADSIJobFlagList(aryStrJobProps(8, lngAryIndex)), ";")
For i = 0 To UBound(aryStrFlagValues)
If i > 0 Then PutCon " "
PutCon aryStrFlagValues(i)
Next
Else
PutCon strTabIndent(lngNrLeadingTabs) & "
"
PutCon "(" & aryStrJobProps(8, lngAryIndex) & ")"
End If
PutCon "
" & vbNewLine
End Sub
Sub ReadJobProperties(ByVal objJob, aryStrJobProps, lngJobCount)
'Function: Puts all properties from a job object to an array.
' The array is resized by parameter "lngJobCount", so this
' function can be called in an enumeration loop.
Redim Preserve aryStrJobProps(10, lngJobCount)
aryStrJobProps(0, lngJobCount) = objJob.Name
aryStrJobProps(1, lngJobCount) = objJob.Description
aryStrJobProps(2, lngJobCount) = objJob.User
aryStrJobProps(3, lngJobCount) = objJob.TimeSubmitted
aryStrJobProps(4, lngJobCount) = objJob.TotalPages
aryStrJobProps(5, lngJobCount) = objJob.Notify
aryStrJobProps(6, lngJobCount) = FormatNumber(objJob.Size, 0, True, False, True)
aryStrJobProps(7, lngJobCount) = objJob.Priority
aryStrJobProps(8, lngJobCount) = objJob.Status
aryStrJobProps(9, lngJobCount) = objJob.PagesPrinted
aryStrJobProps(10, lngJobCount) = objJob.Position
End Sub
Function strADSIJobFlagList(ByVal lngAFlag)
'Function: Builds a list of flags for display.
Const cStrDefDelimiter = ";" 'Der Delimiter für die Liste!
Dim strBinFlags, strFlagNameList
Dim lngFlagMask
Dim bolFirstOccured
lngFlagMask = &H80000000
bolFirstOccured = False
Do While lngFlagMask <> 0
PutDeb "[strADSIAllFlagList]FlagMask:" & strhex(lngFlagMask)
If (lngAFlag And lngFlagMask) > 0 Then
If bolFirstOccured Then
strFlagNameList = strFlagNameList & cStrDefDelimiter & strADSIJobFlagString(lngFlagMask)
Else
bolFirstOccured = True
strFlagNameList = strADSIJobFlagString(lngFlagMask)
End If
End If
lngFlagMask = (lngFlagMask \ 2) And Not lngFlagMask
Loop
strADSIJobFlagList = strFlagNameList
End Function
Function strADSIJobFlagString(ByVal lngAFlag)
'Funktion: Gibt eine textuelle Beschreibung eines Job-Status-Flags zurück. Diese
' entsprechen den ADS(i) Definitionen..
Const clngADS_JOB_PAUSED = &H00000001
Const clngADS_JOB_ERROR = &H00000002
Const clngADS_JOB_DELETING = &H00000004
Const clngADS_JOB_PRINTING = &H00000010
Const clngADS_JOB_OFFLINE = &H00000020
Const clngADS_JOB_PAPEROUT = &H00000040
Const clngADS_JOB_PRINTED = &H00000080
Const clngADS_JOB_DELETED = &H00000100
Select Case lngAFlag
Case clngADS_JOB_PAUSED : strADSIJobFlagString = "ADS_JOB_PAUSED"
Case clngADS_JOB_ERROR : strADSIJobFlagString = "ADS_JOB_ERROR"
Case clngADS_JOB_DELETING : strADSIJobFlagString = "ADS_JOB_DELETING"
Case clngADS_JOB_PRINTING : strADSIJobFlagString = "ADS_JOB_PRINTING"
Case clngADS_JOB_OFFLINE : strADSIJobFlagString = "ADS_JOB_OFFLINE"
Case clngADS_JOB_PAPEROUT : strADSIJobFlagString = "ADS_JOB_PAPEROUT"
Case clngADS_JOB_PRINTED : strADSIJobFlagString = "ADS_JOB_PRINTED"
Case clngADS_JOB_DELETED : strADSIJobFlagString = "ADS_JOB_DELETED"
Case Else : strADSIJobFlagString = "[strADSIJobFlagString]Fehler: Unbekannter Flag Parameter Wert (" & lngAFlag & ") !"
End Select
End Function
Sub WriteTableHeader(byVal lngNrOfTabs)
'Function: Write the jopb object property desscriptions to a HTML table row.
' The table row itself has to be handled outside. The followup of
' the names corresponds to the "WriteJobProperties" procedure.
'Parameter: "lngNrOfTabs" LONG, describes the numer of tabs the
'
should be indended.
'Eleven columns:
PutCon strTabIndent(lngNrOfTabs) & "
" & vbNewLine
End Sub
Function Max(ByVal valA, ByVal valB)
If valA > valB Then
Max = valA
Else
Max = valB
End If
End Function
%>
">
Print Queues/Jobs Übersicht
Printer Queues für Domäne <% = Request.QueryString("Dom") %>
Query at <% = Now() %>
<%
Dim strADSPath, strDom, strComp, strNamespace
Dim strUser, strPwd, strLogonDomain
Dim objNamespace, objDom, objComp, objQue, objJob
Dim lngCompCount, lngQueCount, lngJobCount, lngTotalJobCount
Dim bolAccessDenied
Dim aryStrJobEntries() 'This array holds all job properties while looping.
Dim lngAryIndex
Dim strCellBGColor
'Some initializations:
lngCompCount = 0
lngQueCount = 0
lngJobCount = 0
lngTotalJobCount = 0
'Use the ADS(i) authorization method to ensure you work with
'administrative rights:
strNamespace = "WinNT:"
Set objNamespace = GetObject(strNamespace)
strADSPath = "WinNT://"
'Enumerate all computer objects for this domain:
strDom = Request.QueryString("Dom")
strUser = gcStrUser
strPwd = gcStrPWD
'For debugging:
PutDeb "LogonDomäne=" & strLogonDomain & ", LogonUser=" & Request.ServerVariables("LOGON_USER")
PutDeb "ImpersonatUser=" & strUser & ", Pwd=" & strPwd
PutDeb "ManagedDomain=" & strDom
On Error Resume Next
Set objDom = objNamespace.OpenDSObject _
( _
"WinNT://" & strDom _
, strLogonDomain & "\" & strUser _
, strPwd _
, 0 _
)
If Err Then
If Err = &H80005004 Then
PutCon "Error! " & vbNewLine
PutCon "Invalid username odr password! " & vbNewLine
PutCon "Call your support stuff. " & vbNewLine
Else
PutCon "Error! " & vbNewLine
PutCon "
" & vbNewLine
PutCon "
Script
" & Request.ServerVariables("SCRIPT_NAME") & "
" & vbNewLine
PutCon "
Number
" & Err.Number & "
" & vbNewLine
PutCon "
Description
" & Err.Description & "
" & vbNewLine
PutCon "
Source
" & Err.Source & "
" & vbNewLine
PutCon "
" & vbNewLine
PutCon "Call your support stuff. " & vbNewLine
End If
Err.Clear
Response.End
End If
On Error Goto 0
objDom.Filter = Array("computer")
lngCompCount = 0
For Each objComp in objDom
strComp = objComp.Name
PutDeb " " & vbNewLine & "Next Computer=" & strComp
'Set filter to "PrintQueue":
objComp.Filter = Array("PrintQueue")
lngQueCount = 0
On Error Resume Next
For Each objQue In objComp
If Err Then
PutDeb "Error in ´For Each objQue In objComp´..."
Else
'Remark the state reading queue properties:
bolAccessDenied = False
'Now, there is at minimum one queue; Build the table header:
If lngQueCount = 0 Then
'At minimum one queue is there, open the table, but only at the
'first loop cycle (where "lngQueCount" is already zero):
%>
<% WriteTableHeader(3) %>
<% End If %>
<%
'The next rows contain queue descriptions and job entries.
'Enum the jobs and store the job properties in an array. This has to be
'done because the ROWSPAN parameter must be calculated (All jobs starts
'beneth the queue description, so the description for the queue appears
'only once).
lngJobCount = 0
For Each objJob In objQue.PrintJobs
ReadJobProperties objJob, aryStrJobEntries, lngJobCount
lngJobCount = lngJobCount + 1
Next
%>
valign=top>
<% = strComp %>
Name
<% = objQue.Name %>
<% On Error Resume Next %>
Descr.
<%
PutCon objQue.Description
If Err Then
bolAccessDenied = True
End If
%>
Ort
<% = objQue.Location %>
Path
<% = objQue.PrinterPath %>
<%
strCellBGColor = "#f7efde" 'Set Table standard for background color as default.
If lngJobCount > 0 Then
'Now list all jobs in this queue (from the array).
For lngAryIndex = 0 To lngJobCount - 1
'Arrayindex 5 (number four) contains the submit date-time. If
'this time lies more than 15 minutes in the past, the line
'is shown in another color.
If DateDiff("n", aryStrJobEntries(3, lngAryIndex), Now()) > 15 Then
'Use an alternate background color to show older jobs:
strCellBGColor = "#FFE4C4" 'Bisque.
Else
strCellBGColor = "#f7efde" 'Table standard.
End If
If lngAryIndex > 0 Then PutCon vbNewLine & vbTab & vbTab & "
"
End If
%>
<%
lngQueCount = lngQueCount + 1
lngTotalJobCount = lngTotalJobCount + lngJobCount
End If
Next 'Queue
If lngQueCount = 0 Then
'There were no queues on this machine.
PutCon "
" & _
strComp & _
"
Keine Queues auf diesem Computer.
" & _
vbNewLine
Else
PutCon "
" & vbNewLine
End If
lngCompCount = lngCompCount + 1
Next 'Computer
If lngCompCount = 0 Then PutCon "Keine Computer gefunden. "
Set objNamespace = Nothing
Set objDom = Nothing
Set objComp = Nothing
Set objQue = Nothing
Set objJob = Nothing
If (lngCompCount > 0) And (lngQueCount > 0) Then
%>
Hinweis: Druckjobs die länger als 15 Minuten in einer Queue stehen, sind farblich hervorgehoben.
Summary
Computer
<% = lngCompCount %>
Queues
<% = lngQueCount %>
Jobs
<% = lngTotalJobCount %>
<%
Else
PutCon "Keine Queues gefunden. "
End If
%>
<%
'=== +++ sub's +++ =============================================================
Sub PutCon(strAString)
Response.Write strAString
End Sub
Sub PutDeb(ByVal strAString)
On Error Resume Next
If lBolAppDebug Then
If Err Then
'lBolAppDebug not defined, so don't output the string!
Err.Clear
Else
PutCon strAString & " " & vbNewLine
End If
End If
End Sub
%>