DFSr Backlog script to dump servers and shares out into a text file(or IE window)

''Watch for wraps!
Option Explicit
''135 CHARACTERS IN LANDSCAPE 3         4         5         6         7         8         9        10        11        12         13  13
'123456789112345678921234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789302345
'''GLOBALS==============================================================================================================================

Dim blnFlag, strIETitle
Dim objIe ''As InternetExplorer                                                         ''ie subroutine operands
Dim ubSvr, ubShr, Shr                                             ''INTEGER UBOUND FOR SERVER, SHARE AND SERVER AND SHARE COUNTERS
Dim dateStart                                                     '''Date Start for calculating elapsed time, etc.
Dim strMsg                                                        ''global string message

Const MaxCol = 12                                                 ''Max Columns in fixed-width-output
Const boolDebug = 0 ''''2 = minimal functions- don't use actual parse, etc. 1= use parse, 0=nodebug
Const VBQT = """"                                                 ''VB Quotes
Const UseIE = False                                               ''Use IE as an output
Dim strFilePath
''-------VBS------------------
''uncomment main for VBS to run
MAIN
''-------EXCEL----------------
''uncomment for excel
''Dim wscript As New objWSCRIPT_Emulator

'''====================================================================================================================================
'''Functions===========================================================================================================================
Sub MAIN()

   dateStart = Date + Time()                                      '''Initialize start time
   Dim wshNetwork, strThisComputer, strComputerName               '''WSH windows net shell and String for computer name
   Set wshNetwork = CreateObject("WScript.Network")
   strThisComputer = wshNetwork.ComputerName
  
  
   Dim Servers                                                    '''array of servers for easy reference
   Dim Shares                                                     '''Array of shares for easy reference
   Dim svrS                                                       '''integer for looping sending servers
   Dim svrR                                                       '''integer for looping recieving servers
  
   Dim strCMD                                                     '''SENDING dfsr COMMAND TO DOS
   Dim strPath                                                    '''FIELAPTH TO WRITE TO
  
   ''Set servers and shares------------------------------
   Servers = Array("serverfl", "servermi", "servermn")            '''array of servers for easy reference
   Shares = Array("IMAGES", "IT", "LIB", "MARKETING", _
                  "OPERATIONS", "PROJECT", "SHARE")               '' , "CAD USERS")
   'Shares = Array("PROJECT")                                     ''debug array for shares - faster for debugging-future /SHARE:SWITCH
                                                        
   ubSvr = UBound(Servers)                                        ''REFERENCE NUMBER OF SERVERS - NOTE:: 0-BASED ARRAY
   ubShr = UBound(Shares)                                         ''REFERENCE NUMBER OF SHARES  - NOTE:: 0-BASED ARRAY
  
   '''USW wsh TO SEE IF THIS IS AN ACCEPTABLE ENVIRONMENT TO RUN-----------------------------------------------------------------
   Set wshNetwork = CreateObject("WScript.Network")               ''Set WSH to get computer name------------------------
   strComputerName = wshNetwork.ComputerName                      ''QUICK CHECK IF OK to run
  
   If InStr(LCase(strComputerName), LCase("server")) = 0 And boolDebug = 0 Then
        MsgBox "Script will only run on servers with 'server' in computer name, with 'dfsrdiag' installed.", vbCritical, "Exiting..."
      Exit Sub
   End If
  
   If UseIE Then InitIE "Initializing output", objIe
  
   ''PRIMARY ARRAYS TO HOLD DFSR INFORMATION----------------------''INITIALIZE ARRAYS - PREFORMAT AND FILL WHERE NEEDED--
   ReDim svrgrid(ubShr, ubSvr + 1, ubSvr + 1)                     ''dim grid PER SHARE WITH ROW/HEADER INFORMATION SPACES

   For Shr = 0 To ubShr    ''Borrow svrS=Server Sending to populate tables
      ''FORMAT 1ST TOP LEFT CELL FOR HEADER INFO:==================
      svrgrid(Shr, 0, 0) = PAD(Shares(Shr), MaxCol, 2) & "|" & PAD("RECIEVING SERVER:", _
                               (MaxCol + 1) * 3 - 1, 2) & "|" '& vbCr & PAD("SENDING SVR:", MaxCol, 0)
      For svrS = 0 To ubSvr
         svrgrid(Shr, svrS + 1, 0) = Servers(svrS)                ''PAD(Servers(Svr), MaxCol, 0) ''set up titles
         svrgrid(Shr, 0, svrS + 1) = Servers(svrS)                ''PAD(Servers(Svr), MaxCol, 0)
         svrgrid(Shr, svrS + 1, svrS + 1) = _
                  PAD(String(MaxCol, "-"), MaxCol, 2)             ''fill-in for don't compare servers to self
      Next '''svrS
   Next '''Shr

   ''Input from DFSR stream---------------------------------------------------------------------------------------------------
   For Shr = 0 To ubShr
      MsgIE "Share :: " & Shares(Shr) & vbCr, objIe
       For svrS = 0 To ubSvr
            ''add 1st cell/header information
           
           For svrR = 0 To ubSvr
               If svrgrid(Shr, svrS + 1, 0) _
                  <> svrgrid(Shr, 0, svrR + 1) Then               ''BUILD COMMAND FOR DFSRDIAG
                   strCMD = "dfsrdiag backlog /Smem:" & svrgrid(Shr, svrS + 1, 0) & _
                                            " /Rmem:" & svrgrid(Shr, 0, svrR + 1) & _
                                            " /rgname:" & Shares(Shr) & _
                                            " /rfname:" & Shares(Shr)
                  
                   svrgrid(Shr, svrS + 1, svrR + 1) = ParseCmd(strCMD) ''RUN THE COMMAND AND PARSE THE NEEDED INFO
               End If
           Next   ''svrR  = Server Row index
           ''Table break to wrap==================================
       Next ''svrR= Server
      'Add separation=============================================
   Next 'Shr = Share
   wscript.Sleep 2000

   strThisComputer = wshNetwork.ComputerName
  
   ''output---------------------------------
   If UseIE Then OutputTablesIE svrgrid, objIe
  
   'Set objShell = CreateObject("Wscript.Shell")
   strFilePath = wscript.ScriptFullName
   Do While Right(strFilePath, 1) <> "\" And Len(strFilePath) > 0
      strFilePath = Left(strFilePath, Len(strFilePath) - 1)
   Loop

   strFilePath = strFilePath & strThisComputer & "-" & strDate(dateStart) & "-" & wscript.ScriptName & ".log"
   OutputTablesFile svrgrid, dateStart, strFilePath
  
''Cleanup:
   Set wshNetwork = Nothing
End Sub

Function OutputTablesIE(svrgrid, objIe)
Dim objShell, k, blnFlag, strMsg, strIETitle                    ''ie subroutine operands

   '------------------------------------------------------------
   ''use IE like a console output

   '''alternate if using style sheets
   ''strMsg = "
"
   'strMsg = ""
  
   strMsg = "DFSR Status:: " & strDate(dateStart) & vbCr

   Dim Shr, svrS, svrR                                            ''share and server send and recieve
    For Shr = 0 To ubShr
        strMsg = strMsg & String((MaxCol + 1) * (ubSvr + 2), "-") & vbCr
        ''add 1st cell/header information
        strMsg = strMsg & svrgrid(Shr, 0, 0) & vbCr
        strMsg = strMsg & String((MaxCol + 1) * (ubSvr + 2), "-") & vbCr ''separator
        For svrS = -1 To ubSvr
            For svrR = -1 To ubSvr
               If svrS = -1 And svrR = -1 Then
                  strMsg = strMsg & (PAD("SENDING:", MaxCol, 1)) & "|"
               Else
                  strMsg = strMsg & (PAD(svrgrid(Shr, svrS + 1, svrR + 1), MaxCol, 2)) & "|"
               End If
            Next  ''svrR
            'table break to wrap
            strMsg = strMsg & vbCr
        Next   ''svrS
        'Add separation
        strMsg = strMsg & String((MaxCol + 1) * (ubSvr + 2), "-") & vbCr ''separator
   Next 'share
   '''alternate if using style sheets
   ''strMsg = strMsg & "
"
   'strMsg = strMsg & ""
   MsgIE strMsg & vbCr, objIe
  
End Function

Function OutputTablesFile(svrgrid, strDate, strPath)
   '------------------------------------------------------------
   ''file output
   Dim fso ''As FileSystemObject                                  ''File System Object
   Set fso = CreateObject("Scripting.FileSystemObject")           ''Set FSO to create output file-----------------------
   Dim Shr, svrS, svrR                                            ''share and server send and recieve
   Dim strMsgLine                                                 ''Message Line
   Dim oFile                                                      ''As file Object
   Set oFile = fso.CreateTextFile(strPath)
  
      oFile.WriteLine "DFSR Status:: " & dateStart & vbCr
   
      For Shr = 0 To ubShr
         ''add 1st cell/header information
         oFile.WriteLine String((MaxCol + 1) * (ubSvr + 2), "-") & vbCr
         oFile.WriteLine svrgrid(Shr, 0, 0)
         oFile.WriteLine String((MaxCol + 1) * (ubSvr + 2), "-") ''separator
        
         For svrS = -1 To ubSvr
            strMsgLine = ""
            For svrR = -1 To ubSvr
               If svrS = -1 And svrR = -1 Then
                  strMsgLine = strMsgLine & (PAD("SENDING:", MaxCol, 2)) & "|"
               Else
                  strMsgLine = strMsgLine & (PAD(svrgrid(Shr, svrS + 1, svrR + 1), MaxCol, 2)) & "|"
               End If
            Next  ''svrR
            'table break to wrap
            oFile.WriteLine strMsgLine
         Next   ''svrS
         'Add separation
          oFile.WriteLine String((MaxCol + 1) * (ubSvr + 2), "-") ''separator
         'oFile.WriteLine
      Next 'share

   oFile.Close
   
   Dim WshShell
   Set WshShell = wscript.CreateObject("WScript.Shell")
  
   WshShell.Run "%windir%\system32\notepad.exe  " & strPath, 1, False
    wscript.Sleep 2000
   
   fso.DeleteFile strPath
   Set fso = Nothing
   Set oFile = Nothing
  
Set WshShell = Nothing
End Function

Function PAD(strStr, numChars, justify)
'To justify and pad output
   Dim l, boolJustifyCheck, foo
   foo = True
  
   On Error Resume Next
   boolJustifyCheck = True
  
   If IsMissing(foo) Then  ''this will fail if IsMissing is not a valid function
      boolJustifyCheck = False ''and set boolJustifyCheck to false
   End If
  
   On Error GoTo 0
   If boolJustifyCheck Then
      If IsMissing(justify) Then
         justify = 0
      End If
   End If
  
   l = Len(strStr)
  
   If l < numChars Then
      Select Case justify
         Case 0   '''pad right
            PAD = strStr & Space(numChars)
         Case 1   '''center
            PAD = Space(Round((numChars - l) / 2)) & strStr & Space(Round((numChars - l) / 2))
         Case 2   '''pad left
            PAD = Space(numChars - l) & strStr
      End Select
   Else
      PAD = strStr
   End If
   PAD = Left(PAD & Space(numChars), numChars) ''truncate
End Function

Function strDate(dateDate)
''Format string date in preferred-file-friendly format-----------------
   strDate = Year(Date) & "-" & Right("0" & Month(Date), 2) & "-" & Right("0" & Day(Date), 2) & _
             "-" & Right("0" & Hour(Now()), 2) & Right("0" & Minute(Now()), 2)
   If Not Hour(Now()) < 12 Then strDate = strDate & "p" Else strDate = strDate & "a"
End Function

Function ParseCmd(strCMD)
''Execute command and parse results as needed
Dim strTxt, oShell, oExec

   If boolDebug > 1 Then '''debug<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
      ParseCmd = "-999"
      Exit Function
   End If

   strTxt = ""
   Set oShell = CreateObject("WScript.Shell")
   Set oExec = oShell.Exec(strCMD)
  
   Do While Not oExec.StdOut.AtEndOfStream
         strTxt = LCase(oExec.StdOut.ReadLine())
      If InStr(strTxt, LCase("No Backlog")) > 0 Then
        ''
        ParseCmd = PAD("0", 8, 0)
        Set oShell = Nothing
        Set oExec = Nothing
        Exit Function
      End If
     
      If InStr(strTxt, LCase("Backlog File Count:")) > 0 Then
        ParseCmd = Retval(strTxt, "Backlog File Count:")
        Set oShell = Nothing
        Set oExec = Nothing
        Exit Function
      End If
   Loop
End Function

Sub TestRetval()
   Debug.Print Retval("blah blah Backlog File Count: 11,123", "Backlog File Count:")
End Sub

Function Retval(strTxt, strCmp)
   Dim l
   Dim i
  
   strTxt = LCase(strTxt)
   strCmp = LCase(strCmp)

   l = Len(strTxt)

   i = InStr(strTxt, strCmp)
  Retval = Right(strTxt, l - i - Len(strCmp))
End Function
''--------------------------------------------------
Sub MsgAdd(Msg)
    strMsg = strMsg & Msg
End Sub
''--------------------------------------------------


Sub InitIE(ByVal strMsg, ByRef objIe)
' Subroutine to initialize the IE display box.
Dim intWidth, intHeight, intWidthW, intHeightW
Dim objShell

   Set objShell = CreateObject("WScript.Shell") ''wsh
   Set objIe = CreateObject("InternetExplorer.Application")  '''<<<<<<<<<<<<<>>>>>>>>>
   objIe.Visible = True
    
   blnFlag = True
   strIETitle = "Backlog" & String(40, "-")
  
    objIe.Toolbar = False
    objIe.StatusBar = False
    objIe.Resizable = False
    objIe.Navigate ("about:blank")
       objIe.Visible = True
    Do Until objIe.readyState = 4
      wscript.Sleep 100
    Loop
    intWidth = 500 ''objie.document.parentwindow.screen.availwidth
    intHeight = objIe.document.parentwindow.screen.availheight
    intWidthW = objIe.document.parentwindow.screen.availwidth * 0.6
    intHeightW = objIe.document.parentwindow.screen.availheight * 0.6
    objIe.document.parentwindow.resizeto intWidth, intHeight
    objIe.document.parentwindow.MoveTo (intWidth - intWidthW) / 2, (intHeight - intHeightW) / 2
    objIe.document.Write " " & strMsg & " "
    objIe.document.parentwindow.document.Body.Style.backgroundcolor = "#eeeeFF" ''"lightblue"
    objIe.document.parentwindow.document.Body.Scroll = "yes"
    objIe.document.parentwindow.document.Body.Style.font = "10pt 'courier new'"
    objIe.document.parentwindow.document.Body.Style.BorderStyle = "outset"
    objIe.document.parentwindow.document.Body.Style.borderwidth = "4px"

   
    objIe.document.Title = strIETitle

    wscript.Sleep 100
    objShell.AppActivate strIETitle
End Sub

Sub MsgIE(ByVal strMsg, ByRef objIe)  ''As InternetExplorer)
    ' Subroutine to display message in IE box and detect when the
    ' box is closed by the program or the user.
    Dim objIEDoc
   
    On Error Resume Next
   
    If (strMsg = "IE_Quit") Then
        blnFlag = False
        objIe.quit
    Else
        'If InStr(1, LCase(strMsg), LCase("")) = 0 Then  ''unforamtted HTML
            objIe.document.Body.InnerText = strMsg & objIe.document.Body.InnerText
         'Else
            'objIe.document = strMsg
         'End If
        
        If (Err.Number <> 0) Then
            Err.Clear
            blnFlag = False
            Exit Sub
        End If
        ''objShell.AppActivate strIETitle
    End If
End Sub












Comments

Post a Comment

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Add text fields- this VBA searches through the objects in the first frame until it finds " " in the text some where, truncates everything from and to the right and replaces it with an active countdown timer or current time in the box. Refreshes every 500ms with a prtsafe call so it doesn't bog down the CPU. Add a slide advance to start the next slide and begin automated slide advancement. Attribute VB_Name = "Countdown" Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long Public Sub Wait ( Seconds As Double ) ''non cpu-intensive wait timer '' https://stackoverflow.com/questions/57268161/sleep-wait-timer-in-powerpoint-vba-thats-not-cpu-intensive Dim endtime As Double endtime = DateTime.Timer + Seconds Do WaitMessage DoEvents Loop While DateTime.Timer < endtime End Sub Sub Countdown_from_Start () Dim Time As Date Dim Count As ...
Read more

Revit area plans adding new types and references (Gross and rentable)

Image
Note to self: Add additional (duplicate) gross area and net area schemed under Area Plans And Area schemes... Really counter-intuitive place to put this instead of say...  Area Plans> New Type> Edit Type (ADD) or Create an area plan, then Go to Properties, Edit Type and Duplicate... Always seem to forget this one! 2015-10-16-And for the calculation type... To update: this also applies to Revit as well as LT- The gross calculations cannot be overridden, however the 'rentable' comes in various flavors... From AD Revit help: Applies to Revit LT 2015 Rules are determined by one type of space bordering another space. The following table shows area measurement rules. To find the appropriate measurement rule, find the selected Area Type and the corresponding Bordering Area Type. Gross Building Area Scheme Types Gross Building Area Scheme Types Area Type Selected Bordering Area Type Measurement Rule Gross Building Area Gross Buil...
Read more