Wednesday, February 25, 2015

Improved Deltek "Keyed data" (eport report to CSV) to create folder structure

 Option Explicit  
 Const version = "v2015-02-25-01.0"  
 ''Script takes a csv text based output report from Deltek and uses it to create folder structure on P.  
 Const strFPt = "P:\"    ''Target File PathDim FP  
 Const vbqt = """"        ''define VBQt for quotation mark  
 ''Lots of globals on this one:  
 Public strDataArr        ''Readline of data from file  
 Public strDiscID        ''discipline ID  
 Const RemapE = True     ''Remap E will create the S/SZ folders if E is in the disciplines .  
 Const ForReading = 1, ForWriting = 2, ForAppending = 8 ''  
 ''FILE MANIPULATION OBJECTS AND REFERENCES''''''''''''''''''  
 Dim fso             ''As New FileSystemObject for creating folders  
 Dim objWSH           ''As New WshShell for creating shortcuts  
 Dim strKeyID()          ''for holding string of keys for comare  
 Dim KeySet           ''Bool check if key was set  
 Dim strKeyUB          ''Max ubound of key  
 Dim strDataUB          ''ub of data array  
 Dim StrMsg           ''for building up message  
 Dim intFolderCt         ''Count of folders added  
 Dim intFolderRef        ''Folders referenced  
 Dim MyFile           ''MyFile for opening target file, Textline for holding one line at a time  
 Dim Textline          ''MyFile for opening target file, Textline for holding one line at a time  
 Dim DirLevels          ''Limiting dir levels if 0 ir unspecified limits to 2, if -1 create all subfolders for disciplines  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 ''END VARIABLES'''''''''''''''''''''''''''''''''''''''''''''  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 Main                ''Execute MAIN routine  
 'Dim wscript As New objWSCRIPT_Emulator  ''FOR DEBUGGING IN EXCEL WITH WSCRIPT CLASSES  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 ''MAIN ROUTINE''''''''''''''''''''''''''''''''''''''''''''''  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 Sub Main()  
   Dim FileName, I, temp      ''input file name  
   DirLevels = -99         ''init as -99  
   Call Initilize(True)      ''INITIALIZE VARIABLES (IN ANTICIPATION OF CONVERSAION OF THIS PARAMETER TO A CLASS)  
   ''Sort WSCRIPT ARGS''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
   For I = 0 To wscript.Arguments.count - 1  
     If FileName = "" Then  
       FileName = ReturnMatch(wscript.Arguments(I), "([a-z]:\\(?:[-\w\s\.\d]+\\)*(?:[-\w\s\.\d]+)?)")  
     End If  
     If DirLevels = -99 Then  
       temp = ReturnMatch(wscript.Arguments(I), "\/limit:([-+]{0,1}\d+)")  ''look for string from submatch  
       If temp > "" Then  
       DirLevels = CInt(temp)  
      End If  
     End If  
   Next 'i  
   If DirLevels = -99 And FileName > "" Then  
    temp = CInt(InputBox("Number of sub folders under client?" & vbCr & vbCr & _  
              "(P:\0.client\1.Region\(2.Product)\3.Disciplines\)" & vbCr & vbCr & _  
            "(-1 to create ALL 19+ Disciplines)", "Specify allowable depth of sub-folders", 2))  
    If temp < -1 Or temp > 3 Then  
      DirLevels = 3  
    Else  
      DirLevels = temp  
    End If  
   End If  
   If DirLevels = -99 Then DirLevels = 2  
   If FileName = "" Then  
     StrMsg = "Please create a 'project audit report' in deltek with Project#, client name, project name" & vbCr & _  
          "Save it as a CSV/TXT," & vbCr & _  
          "then drag and drop the report onto the script." & vbCr & _  
          "Or link the script to your SendTo folder " & vbCr & _  
          "and use sendto to send the report." & vbCr & vbCr & _  
          "-----SYNTAX-----------------------------------------------------------------" & vbCr & _  
          wscript.ScriptName & " [filepath] [/limit:nn]" & vbCr & _  
          "-----SWITCHES---------------------------------------------------------------" & vbCr & _  
          "Specify /LIMIT:[folder limit] for allowed subdirs below client(Default 2)" & vbCr & _  
          "  -1 = create all disciplines" & vbCr & _  
          "  0 = Create client\ only " & vbCr & _  
          "  1 = Create client\region only " & vbCr & _  
          "  2 = Create client\region\product only " & vbCr & _  
          "[n...] = Limit to N number of sub-folders deep:" & vbCr & _  
          "    P:\0.client\1.Region\2.Product\3.Disciplines (specified by report)"  
     Terminate (vbOKOnly & vbCritical)  
     Exit Sub  
   ElseIf Not fso.FileExists(FileName) Then  
     StrMsg = "ERROR, Cannot find file " & FileName  
     Terminate (vbOKOnly & vbCritical)  
   End If  
   On Error GoTo 0  
   ' Open the file for input.  
   Set MyFile = fso.OpenTextFile(FileName, ForReading)  
   ' Read from the file and display the results.  
   Do While MyFile.AtEndOfStream <> True      '''while not eof  
     Textline = MyFile.ReadLine         ''Get next line of data  
     Textline = Reformat(Textline)        ''reformats csv to tab delimited and gets rid of quotes  
     If Textline > "" Then            '' if not null  
       If ReturnMatch(Textline, "detail_*") > "" Then  ''if matches detail  
         SetKeyInit (Textline)  
       Else  
         If KeySet Then  
           SetData (Textline)       ''Set data array  
           CreateFolders strDataArr, fso  
         End If  
       End If  
     End If  
   Loop  
   Terminate (vbOKOnly)  
 End Sub  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 '''Initialize variables and file manipulation objects'''''''  
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
 Sub Initilize(noargs)  
   Set fso = CreateObject("Scripting.FileSystemObject")      ''File System Object for creating folders  
   Set objWSH = CreateObject("WScript.Shell")           ''Wscript shell for creating shortcuts  
   Dim q  
   q = Array( _  
       Array("00-00-C-", "00-00-C-Non-trades Client folder", "Non-trades Client folder(If not one of the other categories listed below)"), _  
       Array("01-00-G-", "01-00-G-General-Index", "G General All or any portion of subjects included in Level 2"), _  
       Array("05-00-C-", "05-00-C-Civil", "C Civil All or any portion of subjects included in Level 2"), _  
       Array("06-00-L-", "06-00-L-Landscape", "L Landscape All or any portion of subjects included in Level 2"), _  
       Array("07-00-S-", "07-00-S--Structural", "S Structural All or any portion of subjects included in Level 2"), _  
       Array("07-00-SZ", "07-00-SZ-Structural PM folder", "SZ Structural PROJECT MANAGERS FOLDER"), _  
       Array("08-00-A-", "08-00-A-Architectural", "A Architectural All or any portion of subjects included in Level 2"), _  
       Array("08-00-AZ", "08-00-AZ-Architectural PM FOLDER", "AZ Architectural PROJECT MANAGER FOLDER"), _  
       Array("09-00-I-", "09-00-I-Interiors", "I Interiors All or any portion of subjects included in Level 2"), _  
       Array("09-00-IZ", "09-00-IZ-Interiors PM FOLDER", "IZ Interiors PROJECT MANAGER FOLDER"), _  
       Array("10-00-Q-", "10-00-Q-Equipment", "Q Equipment All or any portion of subjects included in Level 2"), _  
       Array("11-00-F-", "11-00-F-Fire Protection", "F Fire Protection All or any portion of subjects included in Level 2"), _  
       Array("12-00-P-", "12-00-P-Plumbing", "P Plumbing All or any portion of subjects included in Level 2"), _  
       Array("14-00-M-", "14-00-M-Mechanical", "M Mechanical All or any portion of subjects included in Level 2"), _  
       Array("15-00-E-", "15-00-E-Electrical", "E Electrical All or any portion of subjects included in Level 2"), _  
       Array("16-00-T-", "16-00-T-Telecommunications", "T Telecommunications All or any portion of subjects included in Level 2"), _  
       Array("17-00-R-", "17-00-R-Resource Data", "R Resource Data furnished without warrant as to accuracy (e.g. typical or previous drawings used for reference)"), _  
       Array("18-00-X-", "18-00-X-Other Disciplines", "X Other Disciplines All or any portion of subjects included in Level 2"), _  
       Array("19-00-Z-", "19-00-Z-Contractor-Shop Drawings", "Z Contractor /Shop Drawings All or any portion of subjects included in Level 2"), _  
       Array("90-00---", "90-00---Inter-discipline meetings", "This category only used for inter-discipline meetings, i.e. team kickoff.") _  
       )  
   Dim ct  
   ct = UBound(q, 1)  
   ReDim strDiscID(ct + 1, 3)  
   Dim I  
   For I = 0 To ct - 1  
     strDiscID(I + 1, 1) = q(I + 1)(0)  
     strDiscID(I + 1, 2) = q(I + 1)(1)  
     strDiscID(I + 1, 3) = q(I + 1)(2)  
   Next ''I  
   ''these are the variables to look for in exports in the reports  
   ''data will be located in the same slot on one of the following lines  
   ''These are keys to look for- if present they will be > -1 for the 'position of the ID'  
   q = Array( _  
      "detail_BillClientName", _  
      "detail_ClientName", _  
      "detail_WBS3", _  
      "detail_OwnerNumber", _  
      "detail_ClientNumber", _  
      "detail_CLAddress", _  
      "detail_WBS1", _  
      "detail_WBS2", _  
      "detail_WBS3" _  
       )  
   ct = UBound(q, 1)  
   ''strkeyid (#,0) is the id  
   ''strkeyif (#,1) is the 'position of the ID'  
   ''strkeyid (#,2) is the data stored in teh current line for that id  
   ReDim strKeyID(ct, 1)  
   I = 0  
   For I = 0 To ct  
     strKeyID(I, 0) = q(I)  ''key name  
     strKeyID(I, 1) = -1   ''key position  
     ''strKeyID(I, 2) = ""   ''temporary key data  
   Next ''I  
 End Sub  
 Function Reformat(Textline)  
   ''if a line has quites, then there is a comma interfering with the string.. i.e. "lastname, firstname"  
   ''looks for commas inside quotes and substitutes "_"  
   Dim I  
   Dim QTon ''quote on boolean  
   QTon = False  
   Dim aa  
   Reformat = ""  
   For I = 1 To Len(Textline)  
     aa = Mid(Textline, I, 1)  
     If aa = vbTab Then aa = "-"       ''strip out native tabs  
     If aa = vbqt Then            ''IF Quote character then  
       QTon = Not (QTon)            ''flip QTON and drop the character  
     Else                  ''else NOT a quote character  
       If QTon Then              ''Quote on = true then add the character  
         Reformat = Reformat + aa  
       Else                  ''quote on = false- we are outside quotes-  
         If aa = "," Then aa = vbTab     ''substitute TAB for comma  
         Reformat = Reformat + aa      ''Add subbed character  
       End If  
     End If  
   Next ''I  
 End Function  
 Sub Terminate(buttons)  
   If buttons = 0 Then buttons = vbOKOnly  
   On Error Resume Next  
   MyFile.Close  
   MsgBox "Script: " & wscript.ScriptFullName & vbCr & vbCr & _  
       StrMsg & vbCr & vbCr & _  
       "--Results---------------------------------" & vbCr & _  
       Right("0000" & DirLevels, 2) & "  /LEVEL:(Dirlevels) Deep" & vbCr & _  
       Right("0000" & intFolderCt, 2) & "  Folders Created" & vbCr & _  
       Right("0000" & intFolderRef, 2) & "  Folders reviewed" & vbCr, buttons, "Convert Deltek To Folders Version:" & version  
   wscript.quit  
 End Sub  
 Function KGet(KeyID)  
   Dim I, xpos ''counter and x position in tab-delimited data  
   For I = 0 To UBound(strKeyID)  
    If KeyID = strKeyID(I, 0) Then  
      xpos = strKeyID(I, 1)  
      If xpos > 0 Then  
       KGet = strDataArr(xpos)  ''get the position and return corresponding data from the split line array  
       Exit Function  
      Else  
       Exit For ''aware of key but <0 means undefined  
      End If  
    End If  
   Next I  
   KGet = Empty  
 End Function  
 Sub CreateFolders(strDataArr, ObjFso) '' As FileSystemObject)  
   If UBound(strDataArr) < strDataUB Then  
    StrMsg = StrMsg & vbCr & "Null Array Error in Create folder at folder count: " & intFolderRef & vbCr & "Str DATA LINE:" & vbCr & Textline & vbCr  
    Terminate (True)  
   End If  
   Dim ClientBill:   ClientBill = KGet("detail_BillClientName")  
   Dim ClientName:   ClientName = KGet("detail_ClientName") ''  
   Dim Projname:    Projname = KGet("detail_WBS3") ''  
   Dim Owner:     Owner = KGet("detail_OwnerName")  
   Dim OwnerNumb:   OwnerNumb = KGet("detail_OwnerNumber")  
   ''Project Number  
   Dim Prod:      Prod = KGet("detail_WBS2")  
   Dim Disc:      Disc = KGet("detail_WBS3")  
   Dim PCliNo:     PCliNo = KGet("detail_OwnerNumber")  
   Dim Pnum:      Pnum = KGet("detail_WBS1")  
    If Not IsEmpty(Pnum) Then  
    On Error Resume Next  
    Dim PYear, PCliRe, PCProd, count  
      ''---regexp to break up ids in pnumber  
      Dim r, m  
      Set r = New RegExp  
      r.Pattern = "(\d{2})(\d{3})(\d{2})\.(\d{3})"  
      r.IgnoreCase = True  
      Set m = r.Execute(Pnum)  
      count = -1  
      count = m.count  
      If count > 0 Then  
       If m(0).SubMatches.count = 4 Then  
         PYear = m(0).SubMatches(0)  
         PCliNo = m(0).SubMatches(1)  
         PCliRe = m(0).SubMatches(2)  
         PCProd = m(0).SubMatches(3)  
       End If  
      Else  
       r.Pattern = "([a-z,A-Z]+)(\d{2})\.(\d{3})"  
       Set m = r.Execute(Pnum)  
       count = -1  
       count = m.count  
       If count > 0 Then  
         PCliNo = m(0).SubMatches(0)  
         PCliRe = m(0).SubMatches(1)  
         PCProd = m(0).SubMatches(2)  
       Else  
         r.Pattern = "([a-z,A-Z]+)\.(\d{3})"  
         r.IgnoreCase = True  
         Set m = r.Execute(Pnum)  
         count = -1  
         count = m.count  
         If count > 0 Then  
         PCliNo = m(0).SubMatches(0)  
         PCProd = m(0).SubMatches(1)  
         End If  
       End If  
      End If  
    End If  
   Dim FP: FP = strFPt  
   Dim objFolder              ''As Folder  
   Dim Folder               '' As Folder  
   Dim I                  ''counter  
   '''client  
   ''base folder  
   FP = FP & PCliNo  
   If PCliNo = "" Then CreateFoldersCrash ("Project number")  
   If ClientName = "" Then ClientName = Projname  
   Set Folder = FolderCheck(FP, ObjFso, StrClean(ClientName & "(" & PCliNo & ")"))  
   If DirLevels = 0 Then Exit Sub ''limit folder creation at level 0 client  
   '''region folder  
   If PCliRe = "" Then Exit Sub ''CreateFoldersCrash ("Region missing")  
   FP = FP & "\" & PCliRe  
   Set Folder = FolderCheck(FP, ObjFso, StrClean(ClientName))  
   If DirLevels = 1 Then Exit Sub ''limit folder creation at level 1 region  
   '''Product  
   FP = FP & "\" & "-" & PCProd  
   Set Folder = FolderCheck(FP, ObjFso, StrClean("-" & Trim(PCProd) & Trim("-" & Prod)))  
   If DirLevels = 2 Then Exit Sub ''limit folder creation at level 2 Product  
   ''Consultants -- using -1 for dir levels creates all consutlants  
   If DirLevels = -1 Then  
     For I = 1 To UBound(strDiscID, 1)  
       Set Folder = FolderCheck(FP & "\" & strDiscID(I, 1), ObjFso, StrClean(strDiscID(I, 2)))  
     Next 'I  
   Else  ''Pass the value to CheckDiscipline  
     Call CheckDiscipline(FP, ObjFso, Disc)  
   End If  
 End Sub  
 Sub CreateFoldersCrash(Name)  
    MsgBox Name & " missing from report, exiting", vbCritical, "Missing info in report"  
    Terminate vbCritical  
    Exit Sub  
 End Sub  
 Function CheckDiscipline(FP, ObjFso, Disc)  
   Dim Folder  
   Dim I  
   Disc = Trim(Disc)  
   If RemapE And Disc = "E" Then Disc = "S" ''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<Exception to map "E" to "S" for now  
   If Disc > "" Then  
     For I = 1 To UBound(strDiscID)  
       If ReturnMatch(strDiscID(I, 1), ".*?" & Trim(Disc) & ".*?") > "" Then  
         Set Folder = FolderCheck(FP & "\" & strDiscID(I, 1), ObjFso, StrClean(strDiscID(I, 2)))  
       End If  
     Next ''I  
   Else  
   '''optional create all anyway  
   End If  
 End Function  
 Function StrClean(StrToClean)  
   StrToClean = UCase(StrToClean)  
   Dim I, a  
   For I = 1 To Len(StrToClean)  
     a = Mid(StrToClean, I, 1)  
       If a >= "A" And a <= "Z" Or a >= "0" And a <= "9" Or a = "(" Or a = ")" Then  
       StrClean = StrClean & a  
       ElseIf a = " " And Right(StrClean, 1) <> " " Then  
         StrClean = StrClean & a  
       ElseIf Right(StrClean, 1) <> "-" Then  
         StrClean = Trim(StrClean & "-")  
       End If  
   Next ''I  
   Do While Right(StrClean, 1) = "-" Or Right(StrClean, 1) = " "  
     StrClean = Left(StrClean, Len(StrClean) - 1)  
   Loop  
 End Function  
 Function FolderCheck(FP, ObjFso, xcutName)  
   On Error Resume Next  
   Set FolderCheck = ObjFso.GetFolder(FP)  
   intFolderRef = intFolderRef + 1  
   If FolderCheck Is Nothing Then  
     Set FolderCheck = ObjFso.CreateFolder(FP)  
     intFolderCt = intFolderCt + 1  
   End If  
   XCut FolderCheck, xcutName           ''create xcut- if it exists it will be deleted and recreated.  
 End Function  
 Sub XCut(Folder, strXcutName)  
   Dim objScut  
   Dim FN  
   Do While (Right(strXcutName, 1) = " " Or Right(strXcutName, 1) = "-") And Len(strXcutName) > 2  
     strXcutName = Left(strXcutName, Len(strXcutName) - 1)  
   Loop  
   FN = Folder.ParentFolder.path + "\" + strXcutName + ".lnk"  
   If fso.FileExists(FN) Then fso.DeleteFile (FN)  
   Set objScut = objWSH.CreateShortcut(FN)  
   objScut.WindowStyle = 4 ''7=Minimized 0=Maximized 4=Normal  
   objScut.TargetPath = Folder.path  
   objScut.Save  
 End Sub  
 Function ReturnMatch(strStr, strMatch)  
   ''VBA include Microsoft VBSCript Regular Expressions 5_5  
   Dim r 'As New RegExp    ''Regexp engine  
   Dim m 'As MatchCollection ''Return value  
   Dim I, x()  
   'Dim StrMatch ''as pattern match  
   If InStr(1, strMatch, "(") + InStr(1, strMatch, ")") = 0 Then   ''add () for subexpression to return something...  
     If Left(strMatch, 1) <> "(" Then strMatch = "(" & strMatch  
     If Right(strMatch, 1) <> ")" Then strMatch = strMatch & ")"  
   End If  
   Set r = New RegExp  
   r.Pattern = strMatch  
   r.IgnoreCase = True  
   Set m = r.Execute(strStr)  
   ''Regexp os base-o arrays so info rturned starts at (0) not (1)  
   On Error Resume Next  
   If m.count = 0 Then  
     ReturnMatch = ""  ''return null  
     Exit Function    ''nomatch  
   Else  
     ReturnMatch = m(0).SubMatches(0) ''return 1st submatch  
   End If  
 End Function  
 Public Sub SetData(StrRdLn)  
   strDataArr = Split(StrRdLn, vbTab)  
   strDataUB = UBound(strDataArr)  
 End Sub  
 Sub SetKeyInit(StrRdLn)  
   Dim x  
   x = Split(StrRdLn, vbTab)  
   KeySet = True  
   Dim I, j  
   For I = 0 To UBound(x)  ''assocaite positions in the array with data  
    For j = 0 To UBound(strKeyID, 1)  
      If strKeyID(j, 0) = x(I) Then  
       strKeyID(j, 1) = I ''store position of data  
       Exit For  
      End If  
    Next 'j  
   Next 'I  
   strKeyUB = UBound(x)  
 End Sub  

Friday, February 13, 2015

Revit nested family not hosting to "Pick primary host" option in "Stacked wall" condition

Revit nested family not hosting to "Pick primary host" option in "Stacked wall" condition- nested family floats out beyond wall to stacked wall width.

The issue was resolved by hosting the nested family to a reference plan then aligning & locking the reference plane to the wall face's finish.

reloading correctly shrunk up the gap between the nested family and the "Primary host"

Monday, February 9, 2015

Thursday, February 5, 2015

On the Road to VDC Integration~ Geeking out over Revit and MS Access data connections...

On the Road to VDC Integration~ Geeking out over Revit and MS Access data connections...
Personal breakthrough- I finally got an great connection from Revit 2015 to MS Access through a plugin called DBConnect. 
I had to install the ODBCx64 drivers downloaded from Microsoft as even whn I installed the x64 version of office to go with my x64bit everythign else it insisted on rverting to teh x32 ODBC drivers:
http://www.microsoft.com/en-us/download/details.aspx?id=23734 i got from this very useful dude!~
Found this helpful9
Answer
Scottgem replied on 

You can download the drivers here:

http://www.microsoft.com/downloads/details.aspx?familyid=7554F536-8C28-4598-9B72-EF94E038C891&displaylang=e

This file will add Access to the list of file types in the ODBC administrator.

Not sure if its 32 or 64 bit. But it worked on a machine running 64bit Win 7


Hope this helps, Scott<> P.S. Please post a response to let us know whether our answer helped or not. Microsoft Access MVP 2009 Author: Microsoft Office Access 2007 VBA Technical Editor for: Special Edition Using Microsoft Access 2007 and Access 2007 Forms, Reports and Queries
Hope this helps,
Scott<>
Blog: http://scottgem.wordpress.com
Microsoft Access MVP since 2007

Once installed I could use the ODBC connection to create a new export from the current Project.

This exported the nearly 300 database tables of information from Revit. I was then able to create reports from these tables to summarize information from the Revit model.

EXCEL- Holy... Much to my surprise...
I decided to link the information into Excel office 365 as data links. I created a Pivot table of walls and then added areas from another walls table tabulations for wall areas instantly appeared! I about passed out (Probably should not have skipped lunch  8-p

If we use the database to gather and consolidate the information that information and adjustments in it can possibly round-trip back into Revit as well... Don't need Bimlink or any of those others : )

Amazing linking and data available for extraction for any number of possible applications... and it is all finally working on x64bit Revit & MSOffice.

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