Revit Import/Export for families- name this the same as the family(with a .txt not rvt extension) for creating an excel based family library manager!
Sub AddReferences()
''---------------------------------------------------------------------------------------------------------------------------------
'' REFERENCES CURRENTLY AVAILABLE:
AddReferenceGUID ("{000204EF-0000-0000-C000-000000000046}") ''VBA
C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
AddReferenceGUID ("{00020813-0000-0000-C000-000000000046}") ''Excel C:\Program
Files\Microsoft Office\Office14\EXCEL.EXE
AddReferenceGUID ("{0D452EE1-E08F-101A-852E-02608C4D0BB4}") ''MSForms
C:\Windows\system32\FM20.DLL
AddReferenceGUID ("{420B2830-E718-11CF-893D-00A0C9054228}") ''Scripting
C:\Windows\system32\scrrun.dll
AddReferenceGUID ("{F935DC20-1CF0-11D0-ADB9-00C04FD58A0B}") ''IWshRuntimeLibrary C:\Windows\system32\wshom.ocx
AddReferenceGUID ("{3F4DACA7-160D-11D2-A8E9-00104B365C9F}") ''VBScript_RegExp_55
C:\Windows\System32\vbscript.dll\3
AddReferenceGUID ("{565783C6-CB41-11D1-8B02-00600806D9B6}") ''WbemScripting
C:\Windows\system32\wbem\wbemdisp.TLB
AddReferenceGUID ("{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}") ''Office C:\Program
Files\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
''---------------------------------------------------------------------------------------------------------------------------------
End Sub
Sub REVIT_SAVE_TO_CSV_TXT_FILE()
'
' SAVE_TO_CSV_TXT_FILE Macro
'
Dim FN As String
Dim FNtxt As String
FN =
ActiveWorkbook.Name
FN =
ReturnMatch(FN, "(.*)\.(xl[smx]{1,2}|txt)") ''regexp
to stroup xl?? or txt from filename
FNtxt =
ActiveWorkbook.path & "\" & FN & ".TXT"
FN =
ActiveWorkbook.path & "\" & FN & ".XLSm"
Application.DisplayAlerts
= False
ActiveWorkbook.SaveAs _
Filename:=FNtxt,
_
FileFormat:=xlCSV,
_
CreateBackup:=True, _
ConflictResolution:=xlLocalSessionChanges, _
AddToMru:=False
ActiveWorkbook.SaveAs _
Filename:=FN,
_
FileFormat:=xlOpenXMLWorkbookMacroEnabled,
_
CreateBackup:=True, _
ConflictResolution:=xlLocalSessionChanges, _
AddToMru:=True
Application.DisplayAlerts = True
End Sub
Sub Revit_Reload_Current()
Dim FN As String
Dim I As Integer
If MsgBox("This will erase everything and relaod the current
file- continue?", vbCritical + vbYesNoCancel) <>
vbYes Then
MsgBox "Cancelled."
Exit Sub
End If
''strip extension
FN = ThisWorkbook.FullName
I = Len(FN)
Do While Mid(FN, I, 1) <>
"." And I > 0
I = I -
1
Loop
I = I -
1
If I = 0 Then
MsgBox "Error extracting file Name- nothing updated", vbCritical
Exit Sub
End If
FN = Left(FN,
I) & ".txt"
'
Range("A1").Select
With ActiveSheet.QueryTables.add(Connection:=
_
"TEXT;" &
FN _
,
Destination:=Range("$A$1"))
.Name
= "acm_LAYOUT"
.FieldNames
= True
.RowNumbers
= False
.FillAdjacentFormulas
= False
.PreserveFormatting
= True
.RefreshOnFileOpen
= False
.RefreshStyle
= xlOverwriteCells
.SavePassword
= False
.SaveData
= True
.AdjustColumnWidth
= True
.RefreshPeriod
= 0
.TextFilePromptOnRefresh
= False
.TextFilePlatform
= 1252
.TextFileStartRow
= 1
.TextFileParseType
= xlDelimited
.TextFileTextQualifier
= xlTextQualifierNone
.TextFileConsecutiveDelimiter
= False
.TextFileTabDelimiter
= True
.TextFileSemicolonDelimiter
= False
.TextFileCommaDelimiter
= True
.TextFileSpaceDelimiter
= False
.TextFileColumnDataTypes
= Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers
= True
.Refresh
BackgroundQuery:=False
End With
End Sub
Sub REVIT_OPEN_TXT()
Dim strFn As String
strFn = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="TEXT
FILES (*.TXT),")
If LCase(strFn) =
"false" Then
MsgBox "Nothing selected"
Exit Sub
End If
OPEN_TXT strFn
End Sub
Sub OPEN_TXT(strFn As String)
Dim wb As Workbook
Excel.Workbooks.OpenText Filename:=strFn, _
Origin:=437, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlNone,
_
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True _
,
Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(
_
16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), _
Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(
_
29, 1), Array(30, 1), Array(31, 1)),
TrailingMinusNumbers:=True
wb.Columns("A:BB").EntireColumn.AutoFit
'Do While Len(strFN) > 1 And Right(strFN, 1) <>
"\"
' strFN =
Left(strFN, Len(strFN) - 1)
'Loop
'strFN = ActiveWorkbook.Name
strFn = ReturnMatch(strFn, "(.*)\\(.*)\.(xl[smx]{1,2}|txt)", 1) ''regexp to stroup xl?? or txt from filename
strFn = ActiveWorkbook.path & "\" &
strFn & ".XLSX"
ActiveWorkbook.SaveAs Filename:=strFn,
FileFormat:=xlCSV, CreateBackup:=True, _
ConflictResolution:=xlLocalSessionChanges, AddToMru:=False
End Sub
Function ReturnMatch(strStr,
strMatch, Optional SUBMATCH As Integer)
''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(SUBMATCH)
''return 1st submatch
End If
End Function
''================================================================================================================================
''===REFERENCES TOOLS
SECTION=====================================================================================================
''================================================================================================================================
''RESOLUTION
''For any Automation client to be able to access the VBA
object model programmatically, the user running the code must explicitly
''grant access. To turn on access, the user must follow
these steps.
''
''Office 2003 and Office XP
''Open the Office 2003 or Office XP application in
question. On the Tools menu, click Macro, and
''then click Security to open the Macro Security dialog
box.
''
''On the Trusted Sources tab, click to select the Trust
access to Visual Basic Project check box to turn on access.
''Click OK to apply the setting. You may need to restart
the application for the code to run properly if you automate from a
''Component Object Model (COM) add-in or template.
''
''Office 2007
''Open the 2007 Microsoft Office system application in
question. Click the Microsoft Office button, and then click Application
Options.
''Click the Trust Center tab, and then click Trust Center
Settings.
''Click the Macro Settings tab, click to select the Trust
access to the VBA project object model check box, and then click OK.
''Click OK.
''
''---------------------------------------------------------------------------------------------------------------------------------
'' REFERENCES CURRENTLY AVAILABLE:
'' VBA
{000204EF-0000-0000-C000-000000000046} C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
'' Excel
{00020813-0000-0000-C000-000000000046} C:\Program Files\Microsoft
Office\Office14\EXCEL.EXE
'' stdole
{00020430-0000-0000-C000-000000000046} C:\Windows\system32\stdole2.tlb
'' Office {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52} C:\Program Files\Common Files\Microsoft
Shared\OFFICE14\MSO.DLL
'' Scripting
{420B2830-E718-11CF-893D-00A0C9054228} C:\Windows\system32\scrrun.dll
'' IWshRuntimeLibrary
{F935DC20-1CF0-11D0-ADB9-00C04FD58A0B} C:\Windows\system32\wshom.ocx
''---------------------------------------------------------------------------------------------------------------------------------
Private Sub ListReferencePaths()
''http://www.vbaexpress.com/kb/getarticle.php?kb_id=278
'Macro purpose: To
determine full path and Globally Unique Identifier (GUID)
'to each referenced library. Select the reference in the Tools\References
'window, then run this code to get the information on the
reference's library
'OUTPUT TO DEBUG WINDOW FOR COPY-PASTE ABOVE EACH MODULE
Dim strFormat
On Error Resume Next
Dim I As Long
'With ThisWorkbook.Sheets(1)
' .Cells.Clear
'
.Range("A1") = "Reference name"
'
.Range("B1") = "Full path to reference"
'
.Range("C1") = "Reference GUID"
'End With
Debug.Print "''---------------------------------------------------------------------------------------------------------------------------------"
Debug.Print "'' REFERENCES CURRENTLY AVAILABLE:"
On Error GoTo ListReferencePathsErr
For I = 1 To
ThisWorkbook.VBProject.References.count
With
ThisWorkbook.VBProject.References(I)
Debug.Print "AddReferenceGUID(" & VBQT & Trim(Format(.Guid,
"!" & String(40, "@"))) & VBQT & ") ''" &
Format(.Name, "!" & String(32, "@")) & "
" & Format(.FullPath,
"!" & String(64, "@"))
'ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Offset(1,
0) = .name
'ThisWorkbook.Sheets(1
).Range("A65536").End(xlUp).Offset(0, 1) = .FullPath
'ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Offset(0,
2) = .GUID
End With
Next I
Debug.Print "''---------------------------------------------------------------------------------------------------------------------------------"
On Error GoTo 0
Exit Sub
ListReferencePathsErr:
Debug.Print "''---------------------------------------------------------------------------------------------------------------------------------"
Debug.Print "''ERROR-- VBA INACCESSIBLE"
On Error GoTo 0
End Sub
''ThisWorkbook.VBProject.References.AddFromGuid _
''
GUID:="{0002E157-0000-0000-C000-000000000046}", _
'' Major:=5,
Minor:=3
Sub AddReference()
''http://stackoverflow.com/questions/9879825/how-to-add-a-reference-programmatically
Dim VBAEditor 'As VBIDE.VBE
Dim VBProj 'As VBIDE.VBProject
Dim chkRef 'As VBIDE.Reference
Dim BoolExists As Boolean
Set VBAEditor =
Application.VBE
Set VBProj =
ActiveWorkbook.VBProject
'~~> Check if "Microsoft VBScript Regular
Expressions 5.5" is already added
For Each chkRef In VBProj.References
If chkRef.Name = "VBScript_RegExp_55" Then
BoolExists = True
GoTo CleanUp
End If
Next
VBProj.References.AddFromFile "C:\WINDOWS\system32\vbscript.dll\3"
CleanUp:
If BoolExists = True Then
MsgBox "Reference already exists"
Else
MsgBox "Reference Added Successfully"
End If
Set VBProj = Nothing
Set VBAEditor = Nothing
End Sub
''''''------------------------------------------------------------------------------------------------
''http://www.vbaexpress.com/kb/getarticle.php?kb_id=267
Sub AddReferenceGUID(strGUID
As String)
'Macro purpose: To
add a reference to the project using the GUID for the
'reference library
If strGUID = "" Then Exit Sub
Dim theRef As Variant, I As Long
'Update the GUID you need below.
''strGUID = "{00020905-0000-0000-C000-000000000046}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For I =
ThisWorkbook.VBProject.References.count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(I)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next I
'Clear any errors so that error trapping for GUID
additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
Guid:=strGUID,
Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use.
No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
&
"add or remove a reference in this
file" & vbNewLine &
"Please check the " _
&
"references in your VBA
project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Comments
Post a Comment