全局属性编辑器乐筑天下 - Powered by Discuz! Archiver

HasanCAD 发表于 2008-4-3 05:36:28

全局属性编辑器

我已经有一段时间没有在这里发布任何实质性内容了，所以我想分享一下。我昨天很无聊，把它放在一起，它是一个“全局”属性编辑器，列出了当前图形中的所有块（包含属性）
当您从列表中选择一个块时，（它还显示布局），它显示与该块相关的属性，您可以从那里修改属性值
您可以要么
a）仅修改选定块的属性，或b）修改所有布局中该块属性的所有实例。您还可以选择在选择时自动切换到所选块布局，并可以选择缩放到所选的特定块。您还可应用过滤器，仅列出以“abc”等开头的块。您将需要一个用户表单和以下控件：列表框&nbsp&nbsp；名称：LBblocks&nbsp&nbsp；名称：LBATT文本框&nbsp&nbsp；名称：TBfilter&nbsp&nbsp；名称：TBattvalue复选框&nbsp&nbsp；姓名：CBXgoto&nbsp&nbsp；标题：“选择布局”&nbsp&nbsp；名称：CBXzoom&nbsp&nbsp；标题：“选择时缩放到块”&nbsp&nbsp；启用：FALSE&nbsp&nbsp；名称：CBXallLayouts&nbsp&nbsp；标题：“适用于所有布局上的此块”&nbsp&nbsp；名称：Cbfilter&nbsp&nbsp；标题：“应用过滤器”&nbsp&nbsp；名称：CBclear&nbsp&nbsp；标题：“清除过滤器”&nbsp&nbsp；名称：CBupdate&nbsp&nbsp；标题：“更新块”&nbsp&nbsp；名称：CBexit&nbsp&nbsp&nbsp&nbsp&nbsp；标题：“退出”标签&nbsp&nbsp；标题：“属性值”&nbsp&nbsp；标题：“属性列表”&nbsp&nbsp；标题：“块..（一些空格）布局”&nbsp&nbsp；标题：“如果您想对控件进行分组，则只显示以开头的块和几个帧。我有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 Yadaa，风险自负，欢迎发表评论和建议，如果您&#039；你懒惰，在这里&#039；是文件
**** Hidden Message *****

CottageCGirl 发表于 2008-4-3 08:06:40

太棒了！谢谢，gatte命令是我最喜欢的express工具之一。很高兴有一个大大改进的gui版本！

HasanCAD 发表于 2008-4-3 08:23:37

看起来很酷&nbsp；给自己弄了一份
我喜欢列表框排序功能&nbsp；本人&#039；亨迪，我有一些有用的计划。嘿嘿嘿…有用，亨迪

CottageCGirl 发表于 2009-8-10 09:01:23

我想下载代码来测试它，但它&#039；s不工作
谁能把zip文件发给我吗
提前谢谢你

CottageCGirl 发表于 2009-8-14 20:14:33

I&#039；我很懒，但我&#039；我以前从未真正使用过VB。请问你如何运行这个文件？谢谢
ArgV

HasanCAD 发表于 2010-1-11 05:09:22

如何运行此VBA

CottageCGirl 发表于 2010-1-12 00:19:49

解压项目，打开AutoCAD，在命令行中键入VBAMAN，然后出现对话框窗口，选择并加载该项目；J#039~

HasanCAD 发表于 2010-1-12 09:58:44

很好的亨迪…现在不是比赛的时间，但希望很快。

HasanCAD 发表于 2010-1-26 03:21:01

解压项目，打开AutoCAD，在命令行中键入VBAMAN，然后出现对话框窗口，选择并加载该项目；J#039~
我在VBARUN对话框窗口中做了什么，但什么也没有做。搜索后，他没有添加这行用户表单。我说得对吗
秒，这个VBA不处理动态块，即使它有一个属性

页: [1]

乐筑天下's Archiver

全局属性编辑器