Sheet Set Manager API code sample for AutoCAD 2005

Some of you have requested a code sample how to use the Sheet Set Manager API for AutoCAD 2005. Here is one that you can download and take a look at.

' Sheet Set Manager sample
' By Jimmy Bergmark
' Copyright (C) 2005 by JTB World
' www.jtbworld.com
' 2005-01-04
'
' SyncLayoutFileName works on the current opened sheet set
' It makes sure that the file name matches the Sheet number
' It makes sure that the layout name is the Sheet number
' concatenated with the Sheet title
' It includes code that shows who is locking the Sheet Set if it's locked
'
' Permission to use, copy, modify, and distribute this software
' for any purpose and without fee is hereby granted, provided
' that the above copyright notice appears in all copies and
' that both that copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting
' documentation.
'
' JTB World PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
' JTB World SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
' MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  JTB World
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.


Public Sub SyncLayoutFileName()
Dim i As Integer
    ' Return how many Sheets Sets that are open
    i = SheetSetsOpen
    If i > 1 Then
        MsgBox "More than one Sheet Set are open. Make sure only one is open.", _
            vbCritical
        Exit Sub
    ElseIf i = 0 Then
        MsgBox "No Sheet Set is open. Make sure one is open.", vbCritical
        Exit Sub
    End If
    
    Dim ssm As New AcSmSheetSetMgr
    Dim dbIter As IAcSmEnumDatabase
    Dim db As IAcSmDatabase
    Dim ss As AcSmSheetSet
    
    If ssm Is Nothing Then
        MsgBox "Something wrong here: 1", vbCritical
        Exit Sub
    End If
    Set dbIter = ssm.GetDatabaseEnumerator
    If dbIter Is Nothing Then
        MsgBox "Something wrong here: 2", vbCritical
        Exit Sub
    End If
    dbIter.Reset
    
    'get the Database of the first sheetset
    Set db = dbIter.Next
    If db Is Nothing Then
        MsgBox "No Sheet Set open", vbCritical
        Exit Sub
    End If
    Set ss = db.GetSheetSet
    If ss Is Nothing Then
        MsgBox "Cannot get the Sheet Set", vbCritical
        Exit Sub
    End If
    Set oSheetIter = ss.GetSheetEnumerator
    If oSheetIter Is Nothing Then
      Exit Sub
    End If
    Dim lockStatus As AcSmLockStatus
    Let lockStatus = db.GetLockStatus
    If lockStatus = AcSmLockStatus_UnLocked Then
      db.LockDb db
    Else
        Call db.UnlockDb(db, True)
        Let lockStatus = db.GetLockStatus
        If lockStatus <> AcSmLockStatus_UnLocked Then
            Dim sUserName As String
            Dim sMachineName As String
            db.GetLockOwnerInfo sUserName, sMachineName
            MsgBox "The Sheet Set is locked by " & sUserName & _
                " at " & sMachineName, vbCritical
            Exit Sub
        End If
    End If
    
    Dim compEnum As IAcSmEnumComponent
    Set compEnum = ss.GetSheetEnumerator
    
    Call LoopThroughSheets(compEnum)
    
    Call db.UnlockDb(db, True)
End Sub

Private Sub LoopThroughSheets(ByVal compEnum As IAcSmEnumComponent)
    Dim bChanged As Boolean
    Dim comp As IAcSmComponent
    Set comp = compEnum.Next()
    Do While Not comp Is Nothing
        If comp.GetTypeName = "AcSmSheet" Then
            Dim s As AcSmSheet
            Set s = comp
            Dim sNumber As String
            Dim sTitle As String
            Debug.Print s.GetNumber
            Debug.Print s.GetTitle
            Debug.Print s.GetDesc
            Dim oLayout As IAcSmNamedAcDbObjectReference
            Set oLayout = s.GetLayout
            Dim sRFN As String

            bFileFound = True
            On Error Resume Next
            sRFN = oLayout.ResolveFileName
            If Err.Number = -2147024894 Then
                MsgBox "The file for Sheet " & oLayout.GetFileName & _
                    " cannot be found." & vbNewLine & "Number: " & _
                    s.GetNumber & " Title: " & s.GetTitle
                bFileFound = False
            End If
            On Error GoTo 0
            If bFileFound Then
            ThisDrawing.Application.Documents.Open (sRFN)
            ThisDrawing.ActiveSpace = acPaperSpace
            ThisDrawing.MSpace = False
            ZoomExtents
            bChanged = False
            If UCase(ThisDrawing.FullName) = UCase(sRFN) Then
                sTitle = s.GetTitle
                sNumber = s.GetNumber
                ' Can fail if there are multiple layouts
                If ThisDrawing.Layouts.Count > 2 Then
                    MsgBox "This drawing has more than one layout " & _
                    "and there might result in some error", vbCritical
                End If
                If ThisDrawing.ActiveLayout.Name <> sNumber & " " & sTitle Then
                    If sNumber = "" Then
                        ThisDrawing.ActiveLayout.Name = sTitle
                    Else
                        ThisDrawing.ActiveLayout.Name = sNumber & " " & sTitle
                    End If
                    bChanged = True
                End If
                ' Compare the referenced layout and file name
                ' The file name should be the same as the Sheet Number
                Dim sSheetFileName As String
                If s.GetNumber = "" Then
                    sSheetFileName = s.GetTitle & ".dwg"
                    MsgBox "The Sheet " & s.GetTitle & _
                    " doesn't have any Sheet Number so the Title is used as file name"
                Else
                    sSheetFileName = s.GetNumber & ".dwg"
                End If
                If oLayout.GetName <> s.GetTitle Or _
                  UCase(sSheetFileName) <> UCase(ThisDrawing.Name) Then
                    oLayout.InitNew s
                    oLayout.SetName ThisDrawing.ActiveLayout.Name
                    If UCase(sSheetFileName) <> UCase(ThisDrawing.Name) Then
                        Dim oldFullName As String
                        Dim newFullName As String
                        newFullName = ThisDrawing.Path & "\" & sSheetFileName
                        If FileExists(newFullName) Then
                            MsgBox newFullName & " already exist"
                        End If
                        oldFullName = ThisDrawing.FullName
                        ThisDrawing.SaveAs newFullName
                        oLayout.SetFileName newFullName
                        On Error Resume Next
                        Kill (oldFullName)
                        On Error GoTo 0
                    Else
                        oLayout.SetFileName ThisDrawing.FullName
                    End If
                End If
            End If
            ThisDrawing.Close bChanged
            End If
        ElseIf comp.GetTypeName = "AcSmSubset" Then
            Dim sset As AcSmSubset
            Set sset = comp
            Call LoopThroughSheets(sset.GetSheetEnumerator)
        End If
        Set comp = compEnum.Next()
    Loop
End Sub

Private Function FileExists(filename As String) As Boolean
    On Error GoTo ErrorHandler
    FileExists = (GetAttr(filename) And vbDirectory) = 0
ErrorHandler:
End Function