如何将物体放在前面？
你好，因为我在一些区块中使用了抹布，我想把它们放在顶部。有时，块意外放置在线条下方，因此线条完全可见。
因为我还有一个数据库连接，可以选择每个块，所以我也想把它放在同一个例程的顶部。
Public Elem As Object
For Each Elem In ThisDrawing.ModelSpace
With Elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If ((Elem.HasAttributes) And (Left(Elem.EffectiveName, 3) = "G_B") Or (Left(Elem.EffectiveName, 3) = "G_E") Or _
(Left(Elem.EffectiveName, 3) = "G_I") Or (Left(Elem.EffectiveName, 3) = "G_L")) Then
Elem.MoveToTop (DOESNT WORK?!)
End If
End If
End With
Next Elem
VBA帮助对我帮助不大。。。你们能帮帮我吗？
Thnx！！
下面是帮助中的一个示例，略有更改
希望这有意义
Option Explicit
Sub OrderToTop()
' This example creates a SortentsTable object and
' changes the draw order of selected object(s) to top.
Dim oSset As AcadSelectionSet
Dim oEnt
Dim i As Integer
Dim setName As String
setName = "$Order$"
'Make sure selection set does not exist
For i = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(i).Name = setName Then
ThisDrawing.SelectionSets.Item(i).Delete
Exit For
End If
Next i
Set oSset = ThisDrawing.SelectionSets.Add(setName)
oSset.SelectOnScreen
If oSset.Count > 0 Then
ReDim arrObj(0 To oSset.Count - 1) As AcadObject
'Process each object
i = 0
For Each oEnt In oSset
Set arrObj(i) = oEnt
i = i + 1
Next
End If
On Error GoTo Err_Control
'Get an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
'Move selected object(s) to the top
sentityObj.MoveToTop arrObj
Application.Update
Exit Sub
Err_Control:
If Err.Number 0 Then MsgBox Err.Description
End Sub
~'J'~ 谢谢你的回复fixo！
它工作得很好。剩下一个简单的问题。。。。
如何填充骨灰盒？我不想在屏幕上选择。我自己制作了一系列物品：
Sub OrderToTop()
' This example creates a SortentsTable object and
' changes the draw order of selected object(s) to top.
Dim oSset As AcadSelectionSet
Dim oEnt
Dim I As Integer
Dim setName As String
setName = "$Order$"
'Make sure selection set does not exist
For I = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(I).Name = setName Then
ThisDrawing.SelectionSets.Item(I).Delete
Exit For
End If
Next I
Set oSset = ThisDrawing.SelectionSets.Add(setName)
ReDim ssobjs(0 To ThisDrawing.Blocks.Count - 1) As AcadBlock
I = 0
For I = 0 To ThisDrawing.Blocks.Count - 1
Set ssobjs(I) = ThisDrawing.Blocks.Item(I)
Next
' Add the array of objects to the selection set
oSset.AddItems ssobjs
If oSset.Count > 0 Then
ReDim arrObj(0 To oSset.Count - 1) As AcadObject
'Process each object
I = 0
For Each oEnt In oSset
Set arrObj(I) = oEnt
I = I + 1
Next
End If
On Error GoTo Err_Control
'Get an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
'Move selected object(s) to the top
sentityObj.MoveToTop arrObj
Application.Update
Exit Sub
Err_Control:
If Err.Number <> 0 Then MsgBox Err.Description
如果文本为粗体，则会出现错误：对象“IAcadSelectionSet”的方法“AddItems”失败。
我试图将SSOBJ作为Object、Acadentity、Variant和AcadObject进行模糊处理，但它仍然不起作用。
怎么会？发生了什么？答案是什么？
抱歉，您混淆了AcadBlock和AcadBlockReference的概念
请看一下关于
以下是不使用选择集的代码
Sub OrderToTop()
' This example creates a SortentsTable object and
' changes the draw order of inserted block regerence(s) to top.
Dim oEnt As AcadEntity
Dim oLayout As AcadLayout
Dim I As Integer
Dim ssobjs() As AcadEntity
I = 0
For Each oLayout In ThisDrawing.Layouts
For Each oEnt In oLayout.Block
If TypeOf oEnt Is AcadBlockReference Then
ReDim Preserve ssobjs(I) As AcadEntity
Set ssobjs(I) = oEnt
I = I + 1
End If
Next
Next
On Error GoTo Err_Control
'Get an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
'Move selected object(s) to the top
sentityObj.MoveToTop ssobjs 'arrObj
Application.Update
Exit Sub
Err_Control:
If Err.Number <> 0 Then MsgBox Err.Description
End Sub
~'J'~ 总是一个棘手的部分。AcadBlocks等。。。。
但关键是：它工作得很好！
非常感谢！！！：眨眼：
很乐意帮忙
干杯
~'J'~
页:
[1]