Sub Main()
	Dim oDoc As AssemblyDocument = ThisDoc.Document
	CreateBIM(oDoc, False)
	

End Sub

Public Sub CreateBIM(oDoc As AssemblyDocument, Optional ForcePreviewImage As Boolean = False)

'Dim _invApp As Inventor.Application


'_invApp = ThisApplication'ThisDoc.Parent ' ThisApplication

'Dim oDef As AssemblyComponentDefinition

'oDef = oDoc.ComponentDefinition

'Get file Name of Assembly

Dim BaseFileName As String

BaseFileName = Left(oDoc.FullFileName, Len(oDoc.FullFileName) - 4)

Logger.Trace("BaseFileName = " & BaseFileName)
 

'If we want To Skip this Process If the .adsk File already exists, we need To Break here

'If BaseFileName & ".adsk" exists Then Exit Sub

 'Create a New part Document that will be the shrinkwrap substitute

Dim oPartDoc As PartDocument

'True/False means Visable/Invisable

'If ForcePreviewImage Set To False, there will be no preview In the BIM export (TK's preference)

'If ForcePreviewImage Set To True, increased Runtime By 18 seconds in test

Logger.Trace("Add Document")

oPartDoc = ThisApplication.Documents.Add(kPartDocumentObject, , ForcePreviewImage) 'DocumentTypeEnum.kPartDocumentObject
'"\\wasadvault01\InventorShare\Templates\FCP - Standard (in).ipt"

Logger.Trace(oPartDoc.DisplayName)


			'Dim oPartDef As PartComponentDefinition

			'oPartDef = oPartDoc.ComponentDefinition

			'Dim oDerivedAssemblyDef As DerivedAssemblyDefinition

			'oDerivedAssemblyDef = oPartDef.ReferenceComponents.DerivedAssemblyComponents.CreateDefinition(oDoc.FullDocumentName)

			'' Set various shrinkwrap related options

			'oDerivedAssemblyDef.DeriveStyle = DerivedComponentStyleEnum.kDeriveAsSingleBodyWithSeams

			'oDerivedAssemblyDef.IncludeAllTopLevelWorkFeatures = DerivedComponentOptionEnum.kDerivedExcludeAll

			'oDerivedAssemblyDef.IncludeAllTopLevelSketches = DerivedComponentOptionEnum.kDerivedExcludeAll

			'oDerivedAssemblyDef.IncludeAllTopLeveliMateDefinitions = DerivedComponentOptionEnum.kDerivedExcludeAll

			'oDerivedAssemblyDef.IncludeAllTopLevelParameters = DerivedComponentOptionEnum.kDerivedExcludeAll

			'oDerivedAssemblyDef.ReducedMemoryMode = True

			'　

			'　

			'oDerivedAssemblyDef.SetHolePatchingOptions(DerivedHolePatchEnum.kDerivedPatchAll,0.02,0.50)

			''oDerivedAssemblyDef.SetRemoveByVisibilityOptions(DerivedGeometryRemovalEnum.kDerivedRemovePartsOnly, 90, True)

			'' Create the shrinkwrap component

			'Dim oDerivedAssembly As DerivedAssemblyComponent

			'oDerivedAssembly = oPartDef.ReferenceComponents.DerivedAssemblyComponents.Add(oDerivedAssemblyDef)
			'oDerivedAssembly.BreakLinkToFile

'shrinkwrap definition
Dim oSWD As ShrinkwrapDefinition
oSWD = oPartDoc.ComponentDefinition.ReferenceComponents.ShrinkwrapComponents.CreateDefinition(oDoc.FullDocumentName)

Logger.Trace("Shrinkwrap Definition")

Dim oCol As ObjectCollection
oCol = ThisApplication.TransientObjects.CreateObjectCollection

Logger.Trace("Collection")

Dim oOccu As ComponentOccurrence

For Each oOccu In oDoc.ComponentDefinition.Occurrences
	Logger.Trace("Loop")
	oCol.Add(oOccu)
Next

oSWD.AdditionalIncludedOccurrences = oCol

'Set Shrinkwrap Options
oSWD.RemoveInternalParts = True
oSWD.DeriveStyle = kDeriveAsSingleBodyNoSeams
oSWD.UseColorOverrideFromSourceComponent = True
oSWD.RemoveHolesStyle = kShrinkwrapRemoveByRange
oSWD.RemoveHolesDiameterRange = 6

oSWD.BreakLink = True

Logger.Trace("Finish seting shrinkwrap options")

Dim oSWComp As ShrinkwrapComponent

oSWComp = oPartDoc.ComponentDefinition.ReferenceComponents.ShrinkwrapComponents.Add(oSWD)

Logger.Trace("Shrinkwrap finished")

Dim strSubstituteFileName As String

Dim num = 1

strSubstituteFileName = BaseFileName & "_Shrinkwrap" & num & ".ipt"

'Saving this file is essential for export to run sucessfully
Logger.Trace("Try to save part as " & strSubstituteFileName)

'ThisApplication.Documents.Open(oPartDoc.FullFileName)
Logger.Trace("Save Doc?")
'Logger.Trace("oPartDoc Name = " & oPartDoc.FullFileName)

While IO.File.Exists(strSubstituteFileName)
	Logger.Trace("Shrinkwrap file exists, incresing number")
	num = num + 1
	strSubstituteFileName = BaseFileName & "_Shrinkwrap" & num & ".ipt"
	If num > 50 Then
		Exit While
	End If
End While

	oPartDoc.SaveAs(strSubstituteFileName, False)


Logger.Trace("Shrinkwrap saved")

'Properties

Dim Description As String

Dim PartNumber As String

Dim ComponentType As String

Dim Manufacturer As String

Dim Model As String

Dim URL As String

'Set properties

Description = "My Product"

PartNumber = iProperties.Value("Project", "Part Number")

Manufacturer = "My Company"

Model = Right(BaseFileName, 6)

URL = ""

'Release reference to Assembly Doc

oDoc = Nothing

'Set Component Type
ComponentType = "23.75.50.17.31" ' Air Handling Unit

'If Left(Model, 3) = "DFE" Or Left(Model, 3) = "RDE" Then

'ComponentType = "23.40.20.17.14.27" 'Nursery/Children's Furniture

'ElseIf Model = "UCSDKS"

'ComponentType = "23.40.20.24.31" 'Desk

'Else

'ComponentType = "23.40.20.00" 'General Furniture and Specialties

'End If

'Write to the iProperties of the Shrinkwapped Part.

'Part Number needs to be written after file save otherwise will be overwrittem

Dim invPartNoProperty As Object

Dim invDescProperty As Object

Logger.Trace("Line 153- ish")

invPartNoProperty = oPartDoc.PropertySets.Item("Design Tracking Properties").Item("Part Number")

invDescProperty = oPartDoc.PropertySets.Item("Design Tracking Properties").Item("Description")

invPartNoProperty.Value = PartNumber

invDescProperty.Value = Description

Logger.Trace(PartNumber & " , " & Description)

'Get Reference BIM Component

Dim oBIM As BIMComponent

oBIM = oPartDoc.ComponentDefinition.BIMComponent

'Write Component Type Definition

'If this line isn't run, the Model Properties tickbox will not get ticked and Model Properties will not get exported

Logger.Trace("ModelProperties")

oBIM.ComponentDescription.ComponentType = ComponentType

Logger.Trace(ComponetType)

'Get reference for writting Identity Data

Dim oBimOC As BIMComponentPropertySet

oBimOC = oBIM.ComponentDescription.ComponentPropertySets.Item("Identity Data")

Logger.Trace("BIM Idem Data Set")
'Write BIM Identity data

'This must be set after 'Write Component Type Definition' otherwise this data will get wiped

Dim BIMDescProp As BIMComponentProperty

Dim BIMManProp As BIMComponentProperty

Dim BIMModelProp As BIMComponentProperty

Dim BIMURLProp As BIMComponentProperty

BIMDescProp = oBimOC.Item(1)

BIMDescProp.Value = Description

BIMManProp = oBimOC.Item(2)

BIMManProp.Value = Manufacturer

BIMModelProp = oBimOC.Item(3)

BIMModelProp.Value = Model

BIMURLProp = oBimOC.Item(4)

BIMURLProp.Value = URL

'Export .adsk file
Logger.Trace("Properties set, export next")

Dim BIMExport = oPartDoc.File
Logger.Trace("BIM Export = " & BIMExport.FullFileName)


Dim ExportFileName = Left(oPartDoc.FullFileName, Len(oPartDoc.FullFileName) -4)
ExportFileName = ExportFileName & ".rfa"

Dim Location = InputBox("Where would you like to Export To/as:" & vbLf & "Note: file name to be included with extension .rfa" , "Revit-BIM", ExportFileName)

oBIM.ExportBuildingComponent(Location)

'Close the invisibly opened part document.

'If this document isn't closed or unreferenced, a retry of the code will fail.

oPartDoc.Close(False)

oPartDoc = Nothing

End Sub