全局属性编辑器
我有一段时间没有在这里发布任何实质性的东西，所以我认为Id分享这个。我昨天感到无聊，把它放在一起 它是一个全局属性编辑器，它列出了当前图形中的所有块（包含属性）。
当您从列表中选择一个块时（它还显示布局），它显示与该块关联的属性，从那里您可以修改属性值。
您可以
a）仅修改所选块的属性，或
b）在所有布局中修改该块属性的所有实例
您还可以选择在选择时自动切换到所选块布局，并可以选择缩放到所选的特定块
您还可以将过滤器应用于仅列出以abc等
开头的块您将需要一个用户窗体和以下控件：
列表框
名称： LB块
名称： LBatts
文本框
名称： TBfilter
名称： TBattvalue
复选框
名称： CBXgoto 标题： 转到布局 在选择
名称： CBXzoom 标题： 缩放以阻止 启用选择： FALSE
名称： CBXall布局 标题： 应用于此块 在所有布局
上 命令按钮
名称：Cbfilter 标题：应用筛选器
名称：CBclear 标题：清除筛选器
名称：CB更新标题：更新块
名称：CBexit 标题：退出
标签
标题：属性值
标题：属性列表
标题：块 ..（某些空格）布局
标题：如果要对控件进行分组，请仅显示以 开头
的块和几个帧。我有2〜一个用于块过滤器，一个用于块详细信息
下一个代码
Option Explicit
Dim Block1Atts As Variant
Dim Block1 As AcadBlockReference
Private Sub CBclear_Click()
' clear the filter and display all blocks with attributes
LBblocks.Clear
TBfilter.Text = ""
Dim LO As AcadLayout
Dim Ent As AcadEntity
Dim Blk As AcadBlock
For Each LO In ThisDrawing.Layouts
For Each Ent In LO.Block
If TypeOf Ent Is AcadBlockReference Then
Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
If Ent.HasAttributes = True Then
LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
End If
End If
Next
Next
' sort the listbox
LBsort LBblocks
End Sub
Private Sub CBexit_Click()
Unload Me
End Sub
Private Sub CBfilter_Click()
LBblocks.Clear
Dim LO As AcadLayout
Dim Ent As AcadEntity
Dim Blk As AcadBlock
' if the block name matches the filter text(with wildcard)
For Each LO In ThisDrawing.Layouts
For Each Ent In LO.Block
If TypeOf Ent Is AcadBlockReference Then
Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
If Ent.Name Like UCase(TBfilter.Text) & "*" Then
If Ent.HasAttributes = True Then
LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
End If
End If
End If
Next
Next
LBsort LBblocks
End Sub
Private Sub CBupdate_Click()
Dim BLKcoll As AcadSelectionSets
Dim SSetBlks As AcadSelectionSet
Dim NxtBlk As AcadBlockReference
Dim BlkAtts As Variant
Dim X As Integer
' if we are only updating the selected block then....
If CBXallLayouts.Value = False Then
For X = 0 To UBound(Block1Atts)
If LBatts.Value = Block1Atts(X).TagString Then
Block1Atts(X).TextString = TBattValue.Text
End If
Next X
Block1.Update
Exit Sub
Else
' or if we are updating this block across ALL layouts then...
' first check if any ss exist and if they do, delete them
Set BLKcoll = ThisDrawing.SelectionSets
For Each SSetBlks In BLKcoll
If SSetBlks.Name = "SSbks" Then
ThisDrawing.SelectionSets.Item("SSbks").Delete
Exit For
End If
Next
' then get an SS of the blocks
Set SSetBlks = ThisDrawing.SelectionSets.Add("SSbks")
Dim FilterType(0 To 1) As Integer
Dim FilterData(0 To 1) As Variant
FilterType(0) = 0: FilterData(0) = "INSERT"
FilterType(1) = 2: FilterData(1) = Block1.Name
SSetBlks.Select acSelectionSetAll, , , FilterType, FilterData
' loop through the Sset, get attributes and apply the updated value to the attribute
For Each NxtBlk In SSetBlks
BlkAtts = NxtBlk.GetAttributes
For X = 0 To UBound(BlkAtts)
If BlkAtts(X).TagString = LBatts.Value Then
BlkAtts(X).TextString = TBattValue.Text
NxtBlk.Update
End If
Next X
Next NxtBlk
ThisDrawing.SelectionSets.Item("SSbks").Delete
End If
' and clear the global checkbox
CBXallLayouts.Value = False
End Sub
Private Sub CBXgoto_Click()
If CBXgoto.Value = True Then
CBXzoom.Enabled = True
ElseIf CBXgoto.Value = False Then
CBXzoom.Enabled = False
End If
End Sub
Private Sub LBatts_Click()
' dispay the attribute value when clicked
Dim X As Integer
For X = 0 To UBound(Block1Atts)
If LBatts.Value = Block1Atts(X).TagString Then
TBattValue.Text = Block1Atts(X).TextString
End If
Next X
End Sub
Private Sub LBblocks_Click()
TBattValue.Text = ""
Dim BlockName As String
Dim LayoutName As String
Dim BlValue As Variant
' split the text into block name and layout name
BlValue = LBblocks.Value
BlValue = Split(BlValue, vbTab, , vbTextCompare)
BlockName = BlValue(0)
LayoutName = BlValue(1)
Dim BLKcoll As AcadSelectionSets
Dim SSetBlks As AcadSelectionSet
' first check if any ss exist and if they do, delete them
Set BLKcoll = ThisDrawing.SelectionSets
For Each SSetBlks In BLKcoll
If SSetBlks.Name = "SSbks" Then
ThisDrawing.SelectionSets.Item("SSbks").Delete
Exit For
End If
Next
' then get an SS of the blocks
Set SSetBlks = ThisDrawing.SelectionSets.Add("SSbks")
Dim FilterType(0 To 1) As Integer
Dim FilterData(0 To 1) As Variant
FilterType(0) = 0: FilterData(0) = "INSERT"
FilterType(1) = 2: FilterData(1) = BlockName
SSetBlks.Select acSelectionSetAll, , , FilterType, FilterData
' filter for the block on the current layout
FilterLayout SSetBlks, LayoutName
' display the block tag string
Dim i As Integer
Set Block1 = SSetBlks.Item(0)
'If Block1.HasAttributes = True Then
LBatts.Clear
Block1Atts = Block1.GetAttributes
For i = 0 To UBound(Block1Atts)
LBatts.AddItem Block1Atts(i).TagString
Next i
'End If
ThisDrawing.SelectionSets.Item("SSbks").Delete
' if "Go to layout on selection" is checked then
If CBXgoto.Value = True Then
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(LayoutName)
' if "Zoom to block on selection" is checked then get the bounding box of the block
If CBXzoom.Value = True Then
Dim BboxSP As Variant
Dim BboxEP As Variant
Block1.GetBoundingBox BboxSP, BboxEP
' and use the bounding box for a zoom window
Dim BboxP1(0 To 2) As Double
Dim BboxP2(0 To 2) As Double
BboxP1(0) = BboxSP(0): BboxP1(1) = BboxSP(1): BboxP1(2) = BboxSP(2)
BboxP2(0) = BboxEP(0): BboxP2(1) = BboxEP(1): BboxP2(2) = BboxEP(2)
ZoomWindow BboxP1, BboxP2
End If
End If
End Sub
Private Sub UserForm_Initialize()
' find all blocks in drawing and if they have attributes
' then add them to the listbox
Dim LO As AcadLayout
Dim Ent As AcadEntity
Dim Blk As AcadBlock
For Each LO In ThisDrawing.Layouts
For Each Ent In LO.Block
If TypeOf Ent Is AcadBlockReference Then
Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
If Ent.HasAttributes = True Then
LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
End If
End If
Next
Next
' and sort the listbox
LBsort LBblocks
End Sub
Private Function LBsort(LB As ListBox)
' Sort the listbox
Dim LBvar As Variant
Dim i As Integer
For i = 0 To LB.ListCount - 2
If LB.List(i) > LB.List(i + 1) Then
LBvar = LB.List(i)
LB.List(i) = LB.List(i + 1)
LB.List(i + 1) = LBvar
i = -1
End If
Next i
End Function
Private Sub FilterLayout(SS As AcadSelectionSet, LOname As String)
' from code on Autodesk.com by Frank Oquendo
Dim X As Integer
Dim ObjArray() As AcadEntity
Dim Max As Long
Max = -1
For X = 0 To SS.Count - 1
If LCase(ThisDrawing.ObjectIdToObject(SS.Item(X).OwnerID).Layout.Name)LCase(LOname) Then
Max = Max + 1
ReDim Preserve ObjArray(0 To Max)
Set ObjArray(Max) = SS.Item(X)
End If
Next X
SS.RemoveItems ObjArray
End Sub
未完全测试，因此使用风险yada yada yada
评论，欢迎提出建议
哦，如果你懒惰，这里是文件......
**** Hidden Message ***** 太棒了！谢谢
gatte命令是我最喜欢的快速工具之一。很高兴有一个大大改进的gui版本！ 看起来很酷。我给自己弄了一本
我喜欢列表框排序功能。我有一些计划会派上用场亨迪* 我想下载代码来测试它，但它不起作用...
有人可以给我发送zip文件吗？
提前感谢您
我很懒，但我以前从未真正使用过VB。请问您如何运行此文件？谢谢！
-ArgV 如何运行此VBA 解压缩项目
在命令行中打开AutoCAD
键入VBAMAN然后会出现对话框窗口
选择并加载此项目
键入VBARUN
选择您需要运行
~'J'~ 不错的亨德....现在不是玩的时候，但希望很快。 解压项目
打开AutoCAD
在命令行中键入VBAMAN，然后会出现对话框窗口
选择并加载此项目
键入VBARUN
选择您需要运行
~'J'~
我做了，但在VBARUN对话框窗口中没有东西
搜索后，他没有添加此行
Userform.Show
我说得对吗？
第二
这个VBA不处理动态块，即使它有一个属性。
谢谢
页:
[1]