Tuesday, February 2, 2016

Outlook add headers and tags for project IDs


Sub AddHeader(m As Outlook.MailItem, strProjectNumber As String)
'Dim m As Outlook.MailItem
    Dim pa As Outlook.PropertyAccessor
    Dim myOlFormat As Integer
    myOlFormat = m.BodyFormat
    m.BodyFormat = olFormatUnspecified
    'Set m = Application.CreateItem(olMailItem)
    'm.Body = m.Subject
    Set pa = m.PropertyAccessor
    pa.SetProperty "http://schemas.microsoft.com/mapi/string/{00020386-0000-0000-C000-000000000046}/X-MS-Exchange-Organization-AECOM-Project", strProjectNumber
    Select Case myOlFormat
        Case olFormatHTML
            m.HTMLBody = m.HTMLBody & vbCr & "[X-MS-Exchange-Organization-AECOM-Project:" & strProjectNumber & "]"
            m.HTMLBody = m.HTMLBody & vbCr & " & strProjectNumber & "]
"
        Case olFormatPlain, olFormatRichText, olFormatUnspecified
            m.Body = m.Body & vbCr & "[X-MS-Exchange-Organization-AECOM-Project:" & strProjectNumber & "]"
    End Select
End Sub

Monday, February 1, 2016

Revit Split and reorganize content for implementation in Library content by revit version.

''outline version of VBS from CMS file below
''Takes default Revit library and splits it into metric, Imperial and reorganizes IES files and similar to more logical locations.
Option Explicit
'''''''''''''''''
''Dim Wscript As New objWSCRIPT_Emulator
''main
'''''''''''''''''
Const VBQT = """"
Sub main()

    ''take path from drag and drop
    ''  e.g. ObjArgs(=) should be C:\ProgramData\Autodesk\RVT 2015
    ''  Set it as the source path
    ''
    Dim ObjArgs
    Dim i
    ''for drag-n-drop
    Set ObjArgs = Wscript.Arguments ''
    For i = 0 To ObjArgs.count - 1  ''
       Wscript.Echo ObjArgs(i)      ''
    Next
End Sub

Sub SplitRevitLibrary()
    ''use src path
        ''determine if the target folders are where they should be
End Sub

Sub Xcopy(strSource As String, strDest As String)
    Dim strLogFilename
    strLogFilename = " /LOG+:C:\temp\RVT_%version%_SPLIT.txt "
    strSource = " " & VBQT & strSource & VBQT & " "
    strDest = " " & VBQT & strDest & VBQT & " "
    ''wscript.ObjShell.Run ("c:\windows\system32\robocopy.exe " & strSource & strDest & " /e /Z /DCOPY:T /MT:8 /XO /IT /XJ /FFT /DST /XJD /XJF /R:0 /TBD /TEE" & strLogFilename)
End Sub

'@echo off
'Rem file-folder path for drag and drop
'Set source=%~1
'echo %source%'
'
'Rem set source=C:\ProgramData\Autodesk\RVT 2015
'Echo
'Set Version = 2015
'set NewPath=C:\ProgramData\Autodesk
'Echo
'set USImperial=%newpath%\RVT-[client]-I(US)-%Version%
'set USMetric=%newpath%\RVT-[client]-M(US)-%Version%
'set CANMetric=%newpath%\RVT-[client]-M(CAN)-%Version%
'
'Set RoboPrefs=/e /Z /DCOPY:T /MT:8 /XO /IT /XJ /FFT /DST /XJD /XJF /R:0 /TBD /LOG+:%newpath%\RVT_%version%_SPLIT.txt /TEE
'Rem --SET COPY  English Templates (US)
'set Src=%source%\Family Templates\English_I\
'set Dest=%USImperial%\Family_Templates
'robocopy "%Src%" "%Dest%" %RoboPrefs%
'
'Rem --SET COPY **METRIC TEMPLATES**
'set Src=%source%\Family Templates\English\
'set Dest=%USMetric%\Family_Templates
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%CANMetric%\Family_Templates
'robocopy "%Src%" "%dest%" %RoboPrefs%'

'Rem --SET COPY IES For Metric & Imperial
'set Src=%source%\ies\
'set Dest=%USImperial%\Libraries\Lighting\IES
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%CANmetric%\Libraries\Lighting\IES
'robocopy "%Src%" "%dest%" %RoboPrefs%


'Rem --SET COPY Imperial Library<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'set Src=%source%\Libraries\US Imperial
'set Dest=%USImperial%\Libraries
'robocopy "%Src%" "%dest%" %RoboPrefs%'

'Rem --SET COPY US Metric Libraries<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'set Src=%source%\Libraries\US Metric
'set Dest=%USmetric%\Libraries
'robocopy "%Src%" "%dest%"  %RoboPrefs%

'Rem --SET COPY CAN METRIC LIBRARIES
'set Src=%source%\Libraries\Canada
'set Dest=%CANmetric%\Libraries\
'robocopy "%Src%" "%dest%" %RoboPrefs%

'Rem --SET COPY CONDUIT TABLES - Metric & Imperial
'set Src=%source%\Lookup Tables\Conduit
'set Dest=%USImperial%\Libraries\Conduit\Lookup_Conduit
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%USMetric%\Libraries\Conduit\Lookup_Conduit
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%CANmetric%\Libraries\Conduit\Lookup_Conduit
'robocopy "%Src%" "%dest%" %RoboPrefs%

'Rem --SET COPY Metric & Imperial
'set Src=%source%\Lookup Tables\Pipe
'set Dest=%USImperial%\Libraries\PIPE\Lookup_Pipe
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%USMetric%\Libraries\PIPE\Lookup_Pipe
'robocopy "%Src%" "%dest%" %RoboPrefs%
'set Dest=%CANmetric%\Libraries\PIPE\Lookup_Pipe
'robocopy "%Src%" "%dest%" %RoboPrefs%

'Rem --SET COPY Project Templates
'set Src=%source%\Templates\US Imperial
'set Dest=%USImperial%\Project_Templates
'robocopy "%Src%" "%dest%" %RoboPrefs%'

'set Src=%source%\Templates\US Metric
'set Dest=%USMetric%\Project_Templates
'robocopy "%Src%" "%dest%" %RoboPrefs%

'set Src=%source%\Templates\Canada
'set Dest=%CANMetric%\Project_Templates
'robocopy "%Src%" "%dest%" %RoboPrefs%

'Rem --SET COPY Dictionaries
'set Src=%source%
'set Dest=%USImperial%
'robocopy "%Src%" "%dest%"  revitEN?.dic
'set Dest=%USMetric%
'robocopy "%Src%" "%dest%"  revitEN?.dic
'set Dest=%CANMetric%
'robocopy "%Src%" "%dest%"  revitEN?.dic




'pause

Friday, January 22, 2016

VBSCRIPT to localize revit INI settings to current user (Points to MyDocs folders)

Option Explicit
Dim Wscript ''As New objWSCRIPT_Emulator    '' GLOBAL initiated in Main - also For
Debug in Excel
Dim objFSO ''As New FileSystemObject -      '' GLOBAL initiated in MAIN

Dim intTristate ''if file is unicode this variable helpw sith read/write
Const TristateTrue =
-
1
Const TristateFalse =
0
Const ForReading =
1
Const ForWriting =
2
Const ForAppending =
8
   
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Make changes in MainResetUserINI() Subroutine.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
MainResetUserINI    ''runs the function to execute the change in the ini

Sub MainResetUserINI()
    Dim objNetwork
    Set objNetwork =
CreateObject(
"Wscript.Network")

    If MsgBox("WARNING: This will change Revit data File paths to
'"
& UCase(objNetwork.UserName)
&
"'s  folders." & _
              vbCr &
_
              vbCr &
_
              "Typically modificatios in clude repathing for the
Project Path, RootFileFor PointClouds, etc. "
& _
              vbCr &
_
              vbCr &
_
              vbCr &
_
              "Once run this cannot be undone - Continue?", _
              
vbYesNo + vbExclamation, _
              "Revit localize Reference Folders To " & objNetwork.UserName & " User Profile") _
              <>
vbYes
Then
              MsgBox
"Exiting- no changes made"
              Exit Sub
              End If
    '''''''''''''''''''''''''
    ''''GLOBAL INITIALIZE''''
    Set Wscript =
CreateObject(
"WScript.Shell")             ''Sets GLOBAL WSCRIPT for use in all functions/subs
    Set objFSO = CreateObject("Scripting.FileSystemObject") ''Sets GLOBAL File System Object for use in all
functions/subs
    ''''GLOBAL INITIALIZE END'''
    ''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''Local Filepath references
    Dim strREVITlocalProjectPath                            ''local destination for 'local' project files
    Dim fpRevitINI                                          ''Revit INI file location

        ''Revit INI location- can be reset to scan for multiple versions
(2015, 2016, etc)
        fpRevitINI =
Wscript.ExpandEnvironmentStrings(
"%APPDATA%") & "\Autodesk\Revit\Autodesk Revit 2016\Revit.ini"
       
        ''Set local project path relative to User's
"MyDocuments"
       
strREVITlocalProjectPath = Wscript.SpecialFolders(
"MyDocuments") & "\Revit\Revit_LOCAL_PROJ\"
       
        ''Reset [directiories] ProjectPath
        WriteIni
fpRevitINI,
"Directories", "ProjectPath", strREVITlocalProjectPath
        ''Reset [directiories] RootPathForPointClouds
        WriteIni
fpRevitINI,
"Directories", "RootPathForPointClouds",
strREVITlocalProjectPath
   
    Set objFSO = Nothing
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    MsgBox "completed changes. Plesae re-open Revit to see
changes."
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''DO NOT EDIT BELOW THIS LINE- MAKE CHANGES IN
MainResetUserINI''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Begin INI reading code matrix
''Probably don't need to edit anything below this line
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Borrowed from:
'''http://www.robvanderwoude.com/vbstech_files_ini.php
''Ron E. Allen added functions for unicode INI files 2016
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ReadIni(myFilePath,
mySection, myKey)
    ' This function returns a value read from an INI file
    '
    ' Arguments:
    ' myFilePath 
[string]  the (path and) file name
of the INI file
    ' mySection  
[string]  the section in the INI
file to be searched
    ' myKey      
[string]  the key whose value is
to be returned
    '
    ' Returns:
    ' the [string] value for the specified key in the
specified section
    '
    ' CAVEAT:     Will
return a space if key exists but value is blank
    '
    ' Written by Keith Lacelle
    ' Modified by Denis St-Pierre and Rob van der Woude And
Ron E. Allen

    Dim intEqualPos
    Dim ObjIniFile
    Dim strFilePath, strKey,
strLeftString, strLine, strSection

    ReadIni =
""
    strFilePath =
Trim(myFilePath)
    strSection =
Trim(mySection)
    strKey =
Trim(myKey)

    If objFSO.FileExists(strFilePath)
Then

       
CheckSetUnicode (strFilePath)
       
        Set ObjIniFile =
objFSO.OpenTextFile(strFilePath, ForReading,
False, intTristate) ''tristatetrue
opens unicode file tristatefalse opens as ascII which may add nulls between
characters
       
        Do While
ObjIniFile.AtEndOfStream =
False
            strLine =
Trim(ObjIniFile.ReadLine)

            ' Check if section is found in the current line
            If LCase(strLine)
=
"[" & LCase(strSection) &
"]" Then
               
strLine = Trim(ObjIniFile.ReadLine)

                ' Parse lines until the next section is reached
                Do While Left(strLine,
1) <> "["
                    ' Find position of equal sign in the line
                   
intEqualPos = InStr(
1, strLine,
"=", 1)
                    If intEqualPos > 0 Then
                       
strLeftString = Trim(Left(strLine, intEqualPos
-
1))
                       
' Check if item is found in
the current line
                       
If LCase(strLeftString) = LCase(strKey)
Then
                           
ReadIni = Trim(
Mid(strLine,
intEqualPos +
1))
                           
' In case the item exists but
value is blank
                           
If ReadIni = "" Then
                                ReadIni =
" "
                           
End If
                           
' Abort loop when item is
found
                           
Exit Do
                       
End If
                    End If

                    ' Abort if the end of the INI file is reached
                    If ObjIniFile.AtEndOfStream Then Exit Do

                    ' Continue with next line
                   
strLine = Trim(ObjIniFile.ReadLine)
                Loop
            Exit Do
            End If
        Loop
       
ObjIniFile.Close
    Else
        Wscript.Echo
strFilePath &
" doesn't exists.
Exiting..."
        Wscript.quit
1
    End If
End Function

Sub WriteIni(myFilePath,
mySection, myKey, myValue)
    ' This subroutine writes a value to an INI file
    '
    ' Arguments:
    ' myFilePath 
[string]  the (path and) file name
of the INI file
    ' mySection  
[string]  the section in the INI
file to be searched
    ' myKey      
[string]  the key whose value is
to be written
    ' myValue    
[string]  the value to be written
(myKey will be
    '                      
deleted if myValue is <DELETE_THIS_VALUE>)
    '
    ' Returns:
    ' N/A
    '
    ' CAVEAT:    
WriteIni function needs ReadIni function to run
    '
    ' Written by Keith Lacelle
    ' Modified by Denis St-Pierre, Johan Pol and Rob van der
Woude

    Const ForReading =
1
    Const ForWriting =
2
    Const ForAppending =
8

    Dim blnInSection,
blnKeyExists, blnSectionExists, blnWritten
    Dim intEqualPos
    Dim objNewIni, objOrgIni,
wshShell
    Dim strFilePath,
strFolderPath, strKey, strLeftString
    Dim strLine, strSection,
strTempDir, strTempFile, strValue

    strFilePath =
Trim(myFilePath)
    strSection =
Trim(mySection)
    strKey =
Trim(myKey)
    strValue =
Trim(myValue)

    Set wshShell =
CreateObject(
"WScript.Shell")

    strTempDir =
wshShell.ExpandEnvironmentStrings(
"%TEMP%")
    strTempFile =
objFSO.BuildPath(strTempDir, objFSO.GetTempName)

   
    CheckSetUnicode (strFilePath)
   
    Set objOrgIni =
objFSO.OpenTextFile(strFilePath, ForReading,
True, intTristate)
   
    If objFSO.FileExists(strTempFile)
Then
objFSO.DeleteFile strTempFile
   
    Set objNewIni =
objFSO.CreateTextFile(strTempFile,
False, intTristate)
    blnInSection =
False
    blnSectionExists
=
False
    ' Check if the specified key already exists
    blnKeyExists =
(ReadIni(strFilePath, strSection, strKey) <>
"")
    blnWritten =
False

    ' Check if path to INI file exists, quit if not
    strFolderPath =
Mid(strFilePath, 1, InStrRev(strFilePath,
"\"))
    If Not objFSO.FolderExists(strFolderPath)
Then
        Wscript.Echo
"Error: WriteIni failed, folder path
("
_
                   &
strFolderPath &
") to ini
file "
_
                   &
strFilePath &
" not found!"
        Set objOrgIni = Nothing
        Set objNewIni = Nothing
        Wscript.quit
1
    End If

    While
objOrgIni.AtEndOfStream =
False
        strLine =
Trim(objOrgIni.ReadLine)
        If blnWritten = False Then
            If LCase(strLine)
=
"[" & LCase(strSection) &
"]" Then
               
blnSectionExists =
True
               
blnInSection =
True
            ElseIf InStr(strLine,
"[") = 1 Then
               
blnInSection =
False
            End If
        End If

        If blnInSection Then
            If blnKeyExists Then
               
intEqualPos = InStr(
1, strLine,
"=", vbTextCompare)
                If intEqualPos > 0 Then
                   
strLeftString = Trim(Left(strLine,
intEqualPos -
1))
                    If LCase(strLeftString)
= LCase(strKey)
Then
                        ' Only write the key if the value isn't empty
                       
' Modification by Johan Pol
                       
If strValue <> "<DELETE_THIS_VALUE>" Then
                           
objNewIni.WriteLine strKey &
"=" & strValue
                       
End If
                       
blnWritten =
True
                       
blnInSection =
False
                    End If
                End If
                If Not blnWritten Then
                   
objNewIni.WriteLine strLine
                End If
            Else
               
objNewIni.WriteLine strLine
                    ' Only write the key if the value isn't empty
                    ' Modification by Johan Pol
                    If strValue <> "<DELETE_THIS_VALUE>" Then
                       
objNewIni.WriteLine strKey &
"=" & strValue
                    End If
               
blnWritten =
True
               
blnInSection =
False
            End If
        Else
           
objNewIni.WriteLine strLine
        End If
    Wend

    If blnSectionExists = False Then ' section doesn't exist
       
objNewIni.WriteLine
       
objNewIni.WriteLine
"[" & strSection & "]"
            ' Only write the key if the value isn't empty
            ' Modification by Johan Pol
            If strValue <> "<DELETE_THIS_VALUE>" Then
               
objNewIni.WriteLine strKey &
"=" & strValue
            End If
    End If

    objOrgIni.Close
    objNewIni.Close

    ' Delete old INI file
   
objFSO.DeleteFile strFilePath,
True
    ' Rename new INI file
    objFSO.MoveFile
strTempFile, strFilePath

    Set objOrgIni = Nothing
    Set objNewIni = Nothing
    Set wshShell = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Ron Allen Functions

Function IsUnicode(strFilePath)
''As Boolean

    ''Set objFSO =
CreateObject("Scripting.FileSystemObject") ''create fso
    Dim ObjTestFile

    Set ObjTestFile =
objFSO.OpenTextFile(strFilePath, ForReading,
False)
        Dim char1, char2
            char1 =
ObjTestFile.Read(
1)
            char2 =
ObjTestFile.Read(
1)
            If Asc(char1) =
255 And Asc(char2) = 254 Then IsUnicode = True
           
           
ObjTestFile.Close
            ''Set objFSO = Nothing
End Function

Function
CheckSetUnicode(strFilePath)
        If IsUnicode(strFilePath)
Then
           
intTristate = TristateTrue
            Else
           
intTristate = TristateFalse
        End If
    CheckSetUnicode =
intTristate
End Function