<% 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) & "" & aryStrJobProps(0, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(1, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(2, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(3, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(4, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(5, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(6, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(7, lngAryIndex) & "" & 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 PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(9, lngAryIndex) & "" & vbNewLine PutCon strTabIndent(lngNrLeadingTabs) & "" & aryStrJobProps(10, lngAryIndex) & "" & 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) & "Print Queue" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Job" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Description" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "User" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Submitted" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Pages" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Notify" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Size" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Prio" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Status" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Pages printed" & vbNewLine PutCon strTabIndent(lngNrOfTabs) & "Position" & 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 "" & vbNewLine PutCon "" & vbNewLine PutCon "" & vbNewLine PutCon "" & vbNewLine PutCon "
Script" & Request.ServerVariables("SCRIPT_NAME") & "
Number" & Err.Number & "
Description" & Err.Description & "
Source" & Err.Source & "
" & 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 %> <% 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 & "" WriteJobProperties aryStrJobEntries, lngAryIndex, 4, strCellBGColor PutCon "" & vbNewLine Next Else PutCon "" End If %> <% lngQueCount = lngQueCount + 1 lngTotalJobCount = lngTotalJobCount + lngJobCount End If Next 'Queue If lngQueCount = 0 Then 'There were no queues on this machine. PutCon "" & _ vbNewLine Else PutCon "
valign=top> <% On Error Resume Next %>
<% = strComp %>
Name <% = objQue.Name %>
Descr. <% PutCon objQue.Description If Err Then bolAccessDenied = True End If %>
Ort <% = objQue.Location %>
Path <% = objQue.PrinterPath %>
Keine Jobs in dieser Queue.
" & _ strComp & _ "Keine Queues auf diesem Computer.
" & 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 %>