Option Explicit
Dim sheetCount As Integer
Dim sheetSetMgr As IAcSmSheetSetMgr
Dim sheetset As IAcSmSheetSet
Dim sheetdb As IAcSmDatabase
Dim eventHndlr As EventHandler
Dim eventSSMCookie As Long
Dim eventDbCookie As Long
Dim eventSSetCookie As Long
Dim dwtLayoutref As New AcSmAcDbLayoutReference 'default DWT
Dim fileRef As New AcSmFileReference 'default sheet location
Function isInitialized() As Boolean
If sheetSetMgr Is Nothing Then
ThisDrawing.Utility.Prompt "Sheetset manager not initialized!!"
isInitialized = False
End If
If sheetset Is Nothing Then
ThisDrawing.Utility.Prompt "Sheetset not initialized!!"
isInitialized = False
End If
If sheetdb Is Nothing Then
ThisDrawing.Utility.Prompt "Sheetset database not initialized!!"
isInitialized = False
End If
isInitialized = True
End Function
Public Sub CreateSheetSet(name As String, _
path As String, _
desc As String, _
Optional dwtName As String = "", _
Optional dwtPath As String = "", _
Optional defaultSheetLoc As String = "")
On Error Resume Next
'Release previous db and sheet set
Set sheetdb = Nothing
Set sheetset = Nothing
Dim fullPath As String
Dim pos As Integer
pos = Len(path)
'check to see if user entered '\' for path at the end of the string
'if not, append it
If InStr(pos - 1, path, "\") = pos Then
fullPath = path & name & ".dst"
Else
fullPath = path & "\" & name & ".dst"
End If
'Create a new database overwriting existing sheetset file
Set sheetdb = sheetSetMgr.CreateDatabase(fullPath, "", True)
'Lock the database before doing any operation on it
Call LockDatabase
'Get the sheet set from the database
Set sheetset = sheetdb.GetSheetSet
'Set name and description
sheetset.SetName name
sheetset.SetDesc "This is my sheet set " & name & ".dst"
If Len(dwtPath) > 0 Then
Set dwtLayoutref = New AcSmAcDbLayoutReference
dwtLayoutref.InitNew sheetset
dwtLayoutref.SetName dwtName
dwtLayoutref.SetFileName dwtPath + "\" + dwtName
dwtLayoutref.SetName "Sheet"
'Set default dwg template
sheetset.SetDefDwtLayout dwtLayoutref
End If
If Len(defaultSheetLoc) > 0 Then
Set fileRef = New AcSmFileReference
fileRef.InitNew sheetset
fileRef.SetFileName (defaultSheetLoc)
'set default sheet location
sheetset.SetNewSheetLocation fileRef
End If
'Unlock database
Call UnlockDatabase
ThisDrawing.Utility.Prompt ("New sheet set " & fullPath & " created")
ThisDrawing.Application.Update
End Sub
Function AddSheet(parentCategory As IAcSmSubset, _
sheetName As String, _
sheetDesc As String, _
Optional layoutName As String = "", _
Optional layoutDWGPath As String = "") As IAcSmSheet
On Error Resume Next
Dim newSheet As AcSmSheet
If isInitialized = False Then
Exit Function
End If
'Lock the database first
LockDatabase
If parentCategory Is Nothing Then
'category to insert is the sheet set root
Set parentCategory = sheetset
End If
If layoutName = "" Then
If sheetset.GetDefDwtLayout Is Nothing Or sheetset.GetNewSheetLocation Is Nothing Then
ThisDrawing.Utility.Prompt "Cannot add sheet :" & sheetName & vbCrLf
ThisDrawing.Application.Update
Exit Function
Else
'Create a fresh sheet
Set newSheet = parentCategory.AddNewSheet(sheetName, sheetDesc)
newSheet.SetTitle sheetName
' Now insert the sheet
parentCategory.InsertComponent newSheet, Nothing
End If
Else
'Create a sheet based on a layout
Dim layoutRef As New AcSmAcDbLayoutReference
layoutRef.InitNew sheetset
'Set layout name and file name
layoutRef.SetName layoutName
layoutRef.SetFileName layoutDWGPath
'Import a sheet based on a layout into the category
Set newSheet = parentCategory.ImportSheet(layoutRef)
'Now insert the sheet
parentCategory.InsertComponent newSheet, Nothing
End If
'Increment sheet number
sheetCount = sheetCount + 1
'Give the new sheet a number based on sheet count
newSheet.SetNumber sheetCount
'Unlock database
UnlockDatabase
'retrun new sheet
Set AddSheet = newSheet
End Function
Public Sub LockDatabase()
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
Dim lockStatus As AcSmLockStatus
Let lockStatus = sheetdb.GetLockStatus
If lockStatus = AcSmLockStatus_UnLocked Then
sheetdb.LockDb sheetdb
End If
End Sub
Public Sub UnlockDatabase()
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
Dim lockStatus As AcSmLockStatus
If lockStatus = AcSmLockStatus_Locked_Local Or AcSmLockStatus_Locked_Remote Then
sheetdb.UnlockDb sheetdb
End If
End Sub
Function AddSheetCategory(name As String, _
desc As String, _
parentCat As IAcSmSubset) As IAcSmSubset
On Error Resume Next
If isInitialized = False Then
Exit Function
End If
Dim newCat As AcSmSubset
If parentCat Is Nothing Then
'parent category is the sheet set root
Set parentCat = sheetset
End If
'Lock database before we add a category
LockDatabase
Set newCat = parentCat.CreateSubset(name, desc)
'Unlock database
UnlockDatabase
'return the newly created category
Set AddSheetCategory = newCat
End Function
' List all sheets and categories at the command line
Public Sub List(db As IAcSmDatabase)
On Error Resume Next
Dim iter As IAcSmEnumPersist
Dim Item As IAcSmPersist
Dim sheet As IAcSmSheet
Dim subset As IAcSmSubset
Dim cpbag As AcSmCustomPropertyBag
Dim name As String
Dim desc As String
Dim value As String
Set iter = db.GetEnumerator
Set Item = iter.Next
Do While Not Item Is Nothing
Set sheet = Item
Set subset = Item
Set cpbag = Item
'If Not subset Is Nothing Then
If Item.GetTypeName = "AcSmSubset" Then
'list the category (subset)
name = subset.GetName
desc = subset.GetDesc
ThisDrawing.Utility.Prompt ("-------------------------------" & vbCrLf)
ThisDrawing.Utility.Prompt ("SubSet Name :" & name & vbCrLf)
ThisDrawing.Utility.Prompt ("SubSet Desc :" & desc & vbCrLf)
ThisDrawing.Utility.Prompt ("-------------------------------" & vbCrLf)
'ElseIf Not sheet Is Nothing Then
ElseIf Item.GetTypeName = "AcSmSheet" Then
'list the sheet
name = sheet.GetName
desc = sheet.GetDesc
ThisDrawing.Utility.Prompt ("sheet Name :" & name & vbCrLf)
ThisDrawing.Utility.Prompt ("sheet Desc :" & desc & vbCrLf)
ElseIf Item.GetTypeName = "AcSmCustomPropertyBag" Then
'Iterate through custom properties
Dim propIter As IAcSmEnumProperty
Set propIter = cpbag.GetPropertyEnumerator
Dim propName As String
Dim propval As AcSmCustomPropertyValue
Do While True
Set propval = Nothing
propName = ""
propIter.Next name, propval
If propName = "" Then Exit Do 'jump out of loop
If Not IsEmpty(propval) And Not IsObject(propval) Then
ThisDrawing.Utility.Prompt ("Property " & propName & " : " & propval.GetValue & " " & vbCrLf)
End If
Loop
End If
Set Item = iter.Next
Loop
ThisDrawing.Application.Update
End Sub
Public Sub AddCalloutBlock(blockname As String, _
dwg As String)
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
LockDatabase
Dim calloutBlocks As IAcSmCalloutBlocks
Dim calloutRef As New AcSmAcDbBlockRecordReference
Set calloutBlocks = sheetset.GetCalloutBlocks
calloutRef.InitNew sheetdb
calloutRef.SetFileName dwg
calloutRef.SetName blockname
calloutBlocks.Add calloutRef
UnlockDatabase
End Sub
Public Sub AddLabelBlock(blockname As String, _
dwg As String)
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
LockDatabase
Dim labelRef As New AcSmAcDbLayoutReference
labelRef.InitNew sheetdb
labelRef.SetFileName dwg
labelRef.SetName blockname
sheetset.SetDefLabelBlk labelRef
UnlockDatabase
End Sub
Public Sub AddResourceFileLocation(resource As String)
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
LockDatabase
Dim resources As IAcSmResources
Dim fileRef As New AcSmFileReference
Set resources = sheetset.GetResources
fileRef.InitNew sheetdb
fileRef.SetFileName resource
resources.Add fileRef
UnlockDatabase
End Sub
Function AddSheetSelectionSet(name As String, _
desc As String) As IAcSmSheetSelSet
On Error Resume Next
If isInitialized = False Then
Exit Function
End If
'lock database
LockDatabase
Dim sheetSelSets As IAcSmSheetSelSets
Dim sheetSelSet As IAcSmSheetSelSet
Set sheetSelSets = sheetset.GetSheetSelSets
sheetSelSets.Add name, desc, sheetSelSet
'unlock database
UnlockDatabase
'return the selection set
Set AddSheetSelectionSet = sheetSelSet
End Function
Public Sub AddCustomProperty(key As String, _
value As String, _
comp As IAcSmComponent, _
propFlags As PropertyFlags)
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
LockDatabase
Dim bag As IAcSmCustomPropertyBag
If comp Is Nothing Then
Set comp = sheetset
End If
Set bag = comp.GetCustomPropertyBag
Dim propval As New AcSmCustomPropertyValue
propval.InitNew bag
propval.SetFlags propFlags
propval.SetValue value
bag.SetProperty key, propval
UnlockDatabase
End Sub
Public Sub NotifyStart()
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
If Not eventHndlr Is Nothing Then
Exit Sub
End If
Set eventHndlr = New EventHandler
'register for sheet set manager events
Let eventSSMCookie = sheetSetMgr.Register(eventHndlr)
'register database events
Let eventDbCookie = sheetdb.Register(eventHndlr)
'register for sheet set events
Let eventSSetCookie = sheetset.Register(eventHndlr)
End Sub
Public Sub NotifyEnd()
On Error Resume Next
If isInitialized = False Then
Exit Sub
End If
sheetSetMgr.Unregister eventSSMCookie
sheetdb.Unregister eventDbCookie
sheetset.Unregister eventSSetCookie
Set eventHndlr = Nothing
End Sub
Function GetSheetSet() As IAcSmSheetSet
Set GetSheetSet = sheetset
End Function
Public Sub CleanUp(error As String)
On Error Resume Next
If sheetdb Is Nothing Then
Exit Sub
End If
ThisDrawing.Utility.Prompt error & vbCrLf
Dim lockStat As AcSmLockStatus
Set lockStat = sheetdb.GetLockStatus
If lockStat = AcSmLockStatus_Locked_Local Or AcSmLockStatus_Locked_Remote Then
sheetdb.UnlockDb sheetdb
Set sheetdb = Nothing
Set sheetset = Nothing
Set sheetSetMgr = Nothing
Set eventHndlr = Nothing
Set dwtLayoutref = Nothing
Set fileRef = Nothing
End If
End Sub
Private Sub Class_Initialize()
On Error Resume Next
sheetCount = 0
'Get the sheet set manager
Set sheetSetMgr = New AcSmSheetSetMgr
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set sheetdb = Nothing
Set sheetset = Nothing
Set sheetSetMgr = Nothing
Set eventHndlr = Nothing
Set dwtLayoutref = Nothing
Set fileRef = Nothing
End Sub
