Friday, January 23, 2015

Create definition for glossary (Tabe Of Contents #8)

Sub GLOSSARY()
'
' GLOSSARY Macro
'
'
Dim strMark As String
Dim strDEf As String
''Dim newdoc As New Document
'Dim myrange As Range
Dim I As Integer

Dim Curdoc

Set Curdoc = ActiveDocument

''trim up selection
Do While Selection.Characters(Selection.Characters.Count) = " " And Selection.Characters.Count > 1
   Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Loop

strMark = Selection.Text
 
If strMark = "" Then
   MsgBox "Select some text to mark first", vbCritical, "Error"
   Exit Sub
End If

   Selection.Font.Bold = True
   Selection.Font.Italic = True
 
   strDEf = InputBox("Definition for " & strMark, "Define Term", vbOK) ''get definition
 
   strDEf = strMark & "-" & strDEf
Dim x As Field
Set x = Curdoc.TablesOfAuthorities.MarkCitation(Range:=Selection.Range, _
      ShortCitation:=strDEf, LongCitation:= _
      strDEf, LongCitationAutoText:= _
      "MarkCitation3", Category:=8)
   
   ActiveWindow.ActivePane.View.ShowAll = True
 
   x.Select
 
   ''Format definition with find/replace
   Dim strField
   strField = "\l " & VBQT & strMark
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find.Replacement.Font
      .Bold = True
      .Italic = True
   End With
   With Selection.Find
      .Text = strField
      .Replacement.Text = strField ''"\l ""current view only"
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
 
   Set Curdoc = Nothing
    ActiveWindow.ActivePane.View.ShowAll = False
End Sub

Tuesday, January 20, 2015

View FULL headers of selected message(s) in Outlook

Dim objIe ''As InternetExplorer                                                         ''ie subroutine operands
Dim wscript As New objWSCRIPT_emulator

Sub ViewInternetHeader()
    Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
    Dim strheader As String

   InitIE "Starting View Header", objIe

    For Each olItem In Application.ActiveExplorer.Selection
        strheader = GetInetHeaders(olItem)
         MsgIE strheader, objIe
        'Set olMsg = Application.CreateItem(olMailItem)
        'With olMsg
        '    .BodyFormat = olFormatPlain
        '    .Body = strheader
        '    .Display
        'End With
       
    Next
    Set olMsg = Nothing
End Sub


Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ' Purpose: Returns the internet headers of a message.'
    ' Written: 4/28/2009'
    ' Author:  BlueDevilFan'
    ' http://techniclee.wordpress.com/
    ' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function
''----------------------
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 = 800 ''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






Thursday, January 15, 2015

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