图纸集中的自定义道具

Dim aCount As Integer
Dim cCount As Integer
Dim eCount As Integer
Dim iCount As Integer
Dim mCount As Integer
Dim pCount As Integer
Dim sCount As Integer
Dim pidCount As Integer
Dim dwgCount As Integer
Dim scl As String
Dim chk As String
Dim des As String
Dim chrg As String
Dim dwn As String
Dim rinit As String
Dim ssetName As String
Dim ptitle As String
Dim rdesc As String
Dim rdate As String
Dim rtype As String
Dim dNum As String
Dim draw As AcadDocument
Dim newDir As String
Dim newSelSet As IAcSmSheetSelSet
Dim pstamp As String
Dim pLines As String
Dim tLines As String
Dim donce As Boolean
Dim wipeClean As Boolean
Dim sdcCount As Integer
Dim sdcChange As Boolean
Dim NewSubsetStr As String
Dim sdcCalled As Boolean
Dim startDone As Boolean
Dim sdcPrev As Boolean
Dim repTxt As String
Dim expSel As Boolean
Dim xBook As Workbook
Dim dSht As Worksheet
Dim ppSht As Worksheet
Dim ssSht As Worksheet
Dim SingDrawComboPrev As Integer
Public Sub SetProps()
Dim i As Integer
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
    'get the sheetset
    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
      Return
    End If
    'lock the database
    Dim lockStatus As AcSmLockStatus
    Let lockStatus = db.GetLockStatus
    If lockStatus = AcSmLockStatus_UnLocked Then
      db.LockDb db
    Else
        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
    Dim compEnum As IAcSmEnumComponent
    'get component enumerator
    Set compEnum = ss.GetSheetEnumerator
        Call LoopThroughSheetsSetMark(compEnum)
    'unlock the database
    Call db.UnlockDb(db, True)
End Sub
Private Sub LoopThroughSheetsSetMark(ByVal compEnum As IAcSmEnumComponent)
    Dim comp As IAcSmComponent
    Dim lastrevn As Variant
    Dim lyOut As AcSmAcDbLayoutReference
    Dim lyName As String
    Dim lastrevd As String
    Dim lastrevdate As String
    Dim rNumTemp As String
    Dim rnNext As String
    Dim rnVar As Variant
    Dim dirmade As Boolean
    Dim tLine1 As String
    Dim tLine2 As String
    Dim tLine3 As String
    Dim selsets As AcSmSheetSelSets
    Dim selset As AcSmSheetSelSet
    Dim tselset As AcSmSheetSelSet
    Dim ssMade As Boolean
    Dim ttitle As String
    Dim repTemp As String
Dim cssProp As String
Dim exstVal As String
Dim newVal As String
    On Error GoTo ErrHandler
    ssMade = False
    Set comp = compEnum.Next()
    dirmade = False
    cssProp = InputBox("What is the EXACT title of your custom property?", "Property Title")
    ' loop through till the component is Nothing
    Do While Not comp Is Nothing
        'if the component is a sheet, then...
        If comp.GetTypeName = "AcSmSheet" Then
            Dim s As AcSmSheet
            Set s = comp
            Dim sNumber As String
            Dim sTitle As String
            exstVal = GetCSSProperties(cssProp, s)
            sTitle = s.GetTitle
            
            newVal = InputBox("The drawing " & sTitle & vbCr & "has a value of" & vbCr & exstVal & vbCr & _
            "for the Custom Property titled" & vbCr & cssProp & vbCr & vbCr & "Please enter the new value here. Leave blank for no change" _
            , "Properties to the Extreme")
            
            If Not newVal = "" Then
                ChangeProperties cssProp, newVal, s
            End If
         
    ElseIf comp.GetTypeName = "AcSmSubset" Then
            Dim sset As AcSmSubset
            Set sset = comp
            'loop through all the sheets.
            Call LoopThroughSheetsSet(sset.GetSheetEnumerator)
        End If
        'next
        Set comp = compEnum.Next()
    Loop
    GoTo Exit_Here
ErrHandler:
Select Case Err.Number
    Case -2147467259
        Err.Clear
        Resume
    Case Else
        MsgBox Err.Number & ":" & Err.Description, vbOKOnly, "Error " & Err.Number
        GoTo Exit_Here
End Select
Exit_Here:
End Sub

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