So after few attempts to use journal file for automation, I was able to launch Revit from Excel, and added some worksets automatically and saved it into designated folder location. Here are some screenshots:
Workset added from Excel cell values
Folder structures, file name, and worksets are defined in Excel
Result showing the folder structure and Revit files
And the VBA code:
Option Explicit
Sub Project_Setter()
Dim sSource(10) As String
Dim rCrtCell As Range
Dim i As Integer
For i = 0 To UBound(sSource, 1)
sSource(i) = "null"
Next
sSource(0) = ActiveWorkbook.Sheets("Project_Setter").Range("A2").Value
Set rCrtCell = ActiveWorkbook.Sheets("Project_Setter").Range("A5")
If (Len(rCrtCell.Value) > 0) Then
createNewDirectory (Worksheets("Project_Setter").Range("A2").Value)
sSource(1) = rCrtCell.Value
Call moveCell(sSource(), rCrtCell)
End If
End Sub
Sub moveCell(sSource() As String, rCrtCell As Range)
Dim rng As Range
Dim sWorksets As String
sSource(rCrtCell.Column) = rCrtCell.Value
'check if it is folder, revit file, or workset
If (Len(rCrtCell.Value) > 0) Then
If (rCrtCell.Font.Bold = True And rCrtCell.Font.Italic = False) Then
Call makeFolder(sSource(), rCrtCell)
ElseIf (rCrtCell.Font.Bold = False And rCrtCell.Font.Italic = False) Then
sSource(rCrtCell.Column) = "null"
If (Len(ActiveSheet.Cells(rCrtCell.Row, rCrtCell.Column + 1) > 0) And ActiveSheet.Cells(rCrtCell.Row, rCrtCell.Column + 1).Font.Italic = True) Then
sWorksets = ActiveSheet.Cells(rCrtCell.Row, rCrtCell.Column + 1).Value
End If
Call makeRevit(sSource(), rCrtCell, sWorksets)
ElseIf (rCrtCell.Font.Bold = False And rCrtCell.Font.Italic = True) Then
ElseIf (rCrtCell.Font.Bold = True And rCrtCell.Font.Italic = True) Then
MsgBox "Specify """"" & rCrtCell.Value & """"" if it is a folder or a workset"
End If
End If
'determine next cell movement
Dim nextMovement As Integer
nextMovement = valueChecker(rCrtCell)
If (nextMovement = 0) Then
sSource(rCrtCell.Column) = "null"
Call moveCell(sSource(), ActiveSheet.Cells(rCrtCell.Row, rCrtCell.Column - 1))
ElseIf (nextMovement = 1) Then
sSource(rCrtCell.Column) = "null"
Call moveCell(sSource(), ActiveSheet.Cells(rCrtCell.Row + 1, rCrtCell.Column - 1))
ElseIf (nextMovement = 2) Then
Call moveCell(sSource(), ActiveSheet.Cells(rCrtCell.Row + 1, rCrtCell.Column))
ElseIf (nextMovement = 3) Then
Call moveCell(sSource(), ActiveSheet.Cells(rCrtCell.Row + 1, rCrtCell.Column + 1))
Else
MsgBox "Done!"
Exit Sub
End If
End Sub
Function valueChecker(rCrtCell As Range) As Integer
Dim cCol, cRow As Integer
cCol = rCrtCell.Column
cRow = rCrtCell.Row
If (cCol = 1) Then
If (Len(ActiveSheet.Cells(cRow, cCol).Value) = 0) Then
valueChecker = 4
ElseIf (Len(ActiveSheet.Cells(cRow + 1, cCol).Value) > 0) Then
valueChecker = 2
ElseIf (Len(ActiveSheet.Cells(cRow + 1, cCol + 1).Value) > 0) Then
valueChecker = 3
End If
ElseIf (cCol > 1) Then
If (Len(ActiveSheet.Cells(cRow, cCol - 1).Value) > 0) Then
valueChecker = 0
ElseIf (Len(ActiveSheet.Cells(cRow + 1, cCol - 1).Value) > 0) Then
valueChecker = 1
ElseIf (Len(ActiveSheet.Cells(cRow + 1, cCol).Value) > 0) Then
valueChecker = 2
ElseIf (Len(ActiveSheet.Cells(cRow + 1, cCol + 1).Value) > 0) Then
valueChecker = 3
End If
End If
End Function
Function makeFolder(sSource() As String, rCrtCell As Range)
Dim sPath As String
Dim i As Integer
sPath = sSource(0)
For i = 1 To rCrtCell.Column
sPath = sPath & "\" & sSource(i)
createNewDirectory (sPath)
Next
End Function
Function makeRevit(sSource() As String, rCrtCell As Range, sWorksets As String)
Dim worksetCollection As New Collection
Dim sFileName, sPath, sFullPath, strProgramName, strArgument, sJrn1, sJrn2 As String
Dim rng, c As Range
Dim i, j, k As Integer
Dim sWorksetArray, s As Variant
'set saving path
sFileName = rCrtCell.Value
sPath = sSource(0)
strProgramName = "C:\Program Files\Autodesk\Revit 2015\Revit.exe"
strArgument = sPath & "\tempJrn.txt"
For i = 1 To (rCrtCell.Column - 1)
sPath = sPath & "\" & sSource(i)
Next
sFullPath = sPath & "\" & sFileName & ".rvt"
'crate journal file
k = 1
Set rng = Worksheets("Make_Revit").Range("A1:A12")
Open strArgument For Output As #1
For Each c In rng 'add workset code between row 10 and 11
If (k = 12) Then
If (Len(sWorksets) > 0) Then
sWorksetArray = Split(sWorksets, ",")
j = 0
For Each s In sWorksetArray
worksetCollection.Add s
j = j + 1
Next
Print #1, Worksheets("Make_Workset").Range("A1").Value
Print #1, Worksheets("Make_Workset").Range("A2").Value
Print #1, "Jrn.Edit" & " " & """" & "Modal" & " " & "," & " " & "Worksharing" & " " & "," & " " & "Dialog_Revit_PartitionsEnable" & """" & " " & "," & " " & """" & "Control_Revit_PartitionsEnableOthersEdit" & """" & "," & " " & """" & "ReplaceContents" & """" & "," & " " & """" & sWorksetArray(0) & """"
Print #1, Worksheets("Make_Workset").Range("A4").Value
Print #1, Worksheets("Make_Workset").Range("A5").Value 'Transaction Successful
If (j > 1) Then
Dim h As Integer
For h = 1 To j - 1
Print #1, Worksheets("Make_Workset").Range("A6").Value
Print #1, "Jrn.Edit" & " " & """" & "Modal" & " " & "," & " " & "New Workset" & " " & "," & " " & "Dialog_Revit_NewPartition" & """" & "," & " " & """" & "Control_Revit_NewPartitionName" & """" & "," & " " & """" & "ReplaceContents" & """" & " " & "," & " " & """" & sWorksetArray(h) & """"
Print #1, Worksheets("Make_Workset").Range("A8").Value
Next
Print #1, "Jrn.ComboBox" & " " & """" & "Modal" & " " & "," & " " & "Worksets" & " " & "," & " " & "Dialog_Revit_Partitions" & """" & " " & "," & " " & """" & "Control_Revit_ActivePartitionCombo" & """" & "," & " " & """" & "SelEndOk" & """" & "," & " " & """" & sWorksetArray(j - 1) & """"
Print #1, "Jrn.ComboBox" & " " & """" & "Modal" & " " & "," & " " & "Worksets" & " " & "," & " " & "Dialog_Revit_Partitions" & """" & " " & "," & " " & """" & "Control_Revit_ActivePartitionCombo" & """" & "," & " " & """" & "Select" & """" & "," & " " & """" & sWorksetArray(j - 1) & """"
Print #1, Worksheets("Make_Workset").Range("A9").Value 'Jrn.PushButton "Modal , Worksets , Dialog_Revit_Partitions", "OK, IDOK"
Print #1, Worksheets("Make_Workset").Range("A10").Value 'Transaction Successful
ElseIf (j = 1) Then
Print #1, Worksheets("Make_Workset").Range("A9").Value 'Jrn.PushButton "Modal , Worksets , Dialog_Revit_Partitions", "OK, IDOK"
End If
End If
End If
Print #1, c.Value
k = k + 1
Next
sJrn1 = "Jrn.Data" & " " & """" & "File" & " " & "Name" & """" & "," & " " & """" & "IDOK" & """" & "," & " " & """" & sFullPath & """"
sJrn2 = "Jrn.Command" & " " & """" & "SystemMenu" & """" & " " & "," & " " & """" & "Quit the application; prompts to save projects" & " " & "," & " " & "ID_APP_EXIT" & """"
Print #1, sJrn1
Print #1, sJrn2
Close
If (ShellAndWait("""" & strProgramName & """" & " " & strArgument, 1000000, vbNormalFocus, PromptUser) = 1) Then
Call DeleteFile(strArgument)
End If
'Call Shell("""" & strProgramName & """" & " " & strArgument, vbNormalFocus)
End Function
Public Sub createNewDirectory(directoryName As String)
If Not DirExists(directoryName) Then
MkDir (directoryName)
End If
End Sub
Function DirExists(DirName As String) As Boolean
On Error GoTo ErrorHandler
DirExists = GetAttr(DirName) And vbDirectory
ErrorHandler:
End Function
Sub DeleteFile(ByVal FileToDelete As String)
If FileExists(FileToDelete) Then 'See above
SetAttr FileToDelete, vbNormal
Kill FileToDelete
End If
End Sub
Function FileExists(ByVal FileToTest As String) As Boolean
FileExists = (Dir(FileToTest) <> "")
End Function
Hojoong Chung 