图纸集中的自定义道具乐筑天下 - Powered by Discuz! Archiver

Murph 发表于 2008-2-26 06:41:26

标记，
插入一个新模块并将此代码粘贴到其中
这将要求您更改属性标题，为您提供现有值并允许您更改它
这是一个示例，向您展示其余部分是如何工作的
穆尔夫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

Murph 发表于 2008-2-26 10:10:10

嘿Murph我真的很感激；我一直在进步，但进展很慢
这东西不是很直观
好的，我把代码复制到一个新模块中；我仍然是de进入新模块；但我还是有一些错误
我做的第一件事就是把你必须擅长的任何参考文献都注释掉；现在
另一件事是，这个代码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
它告诉我，实际上没有打开的图纸集；所以我把它注释掉了
我可能做错了什么，但我打开了图纸集管理器并加载了一个图纸集，我使用的是CAD附带的示例（civil），我打开并激活了一个布局
另外，我现在看到sUserName、SmacheName是数据库GetLockOwnerInfo方法的一部分
有了这个，我一直得到一个错误，那就是我在我的机器上锁定了图纸集
那么，我们是否过早地锁定了板材放置
还有，我们是否缺少一个函数：
再次感谢您为我破解代码；这使得它更加全面
I&#039；我只是不太清楚为什么我们会犯这样的错误
标记

Murph 发表于 2008-2-26 10:31:32

标记，
GetCSSProperties应该包含在我链接到的dvb中。
您可以在设置I=SheetSetsOpen的地方停止代码，并检查我的值吗
您正在运行什么版本/风格的Autocad
关于被锁定的图纸集，如果您一直在使用同一个图纸集进行测试，那么它可能仍然会从上次出错时起被锁定
查找并运行SheetSetSheet。现在解锁，然后运行我之前给你的东西
告诉我接下来会发生什么
Murph

Murph 发表于 2008-2-26 10:36:30

嘿，Murph，我需要得到这个函数，然后把它粘贴到代码的其余部分下面，对吗
我逐步完成了代码，返回0。我正在使用Land Desktop 2006。此外，我只是创建了一个单独的模块来解锁数据库
有什么建议吗
谢谢
标记

Murph 发表于 2008-2-26 10:56:30

好的，Murph，我从你的另一个项目中复制了3个函数：GetCSSProperties，ChangeProperties+，LoopThroughSheets（末尾有标记），现在，它正在工作；我现在收到输入框的提示，没有任何错误
现在，我需要弄清楚在每个输入框中输入什么

页: 1 [2]

乐筑天下's Archiver