乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 31|回复: 1

急急急 由块名得到块中的所有属性

[复制链接]

11

主题

24

帖子

4

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
68
发表于 2004-12-23 17:06:00 | 显示全部楼层 |阅读模式
急急急 由块名得到块中的所有属性
回复

使用道具 举报

4

主题

27

帖子

3

银币

初来乍到

Rank: 1

铜币
43
发表于 2004-12-24 17:34:00 | 显示全部楼层
'===================================
                         '===================================
                         '========如果有属性修改任务=========
                         '===================================
                         '===================================
                         DoEvents
                         fileright = False
                         If Check7.Value = 1 Then
                                                         If dwgfile.ActiveSpace = acModelSpace Then
                                                                                                         For Each obj In dwgfile.ModelSpace
                                                                                                                                                         cadmessage.Label7.Caption = "正在进行属性修改: 查找目标块块 " & mainblock & " 当前 " & obj.ObjectName
                         
                                                                                                                                                         If obj.ObjectName = "AcDbBlockReference" Then
                                                                                                                                                                                         If obj.Name = mainblock Then
                                                                                                                                                                                         fileright = True
                                                                                                                                                                                         cadmessage.Label7.Caption = "正在进行属性修改: 已找到         " & mainblock & " 当前正属性修改中。。。"
                                                                                                                                                                                         objatts = obj.GetAttributes
                                                                                                                                                                                         For m = LBound(objatts) To UBound(objatts)
                                                                                                                                                                                                                         For n = 0 To Combo6.ListCount - 1
                                                                                                                                                                                                                         If objatts(m).TagString = Combo6.List(n) Then
                                                                                                                                                                                                                                                         If Combo8.List(n)  "" Then
                                                                                                                                                                                                                                                                                         If Combo8.List(n) = "null" Or Combo8.List(n) = "NULL" Then
                                                                                                                                                                                                                                                                                                                         objatts(m).TextString = ""
                                                                                                                                                                                                                                                                                                                         Exit For
                                                                                                                                                                                                                                                                                         Else
                                                                                                                                                                                                                                                                                         objatts(m).TextString = Combo8.List(n)
                                                                                                                                                                                                                                                                                         Exit For
                                                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         Next n
                                                                                                                                                                                         Next m
                                                                                                                                                                                         End If
                                                                                                                                                         End If
                                                                                                                         Next obj
                                                         End If
                                                         
                                                         
                                                         If dwgfile.ActiveSpace = acPaperSpace Then
                                                                                                         For Each obj In dwgfile.PaperSpace
                                                                                                                                                         cadmessage.Label7.Caption = "正在进行属性修改: 查找目标块块 " & mainblock & " 当前 " & obj.ObjectName
                                                                                                                                                         If obj.ObjectName = "AcDbBlockReference" Then
                                                                                                                                                                                         If obj.Name = mainblock Then
                                                                                                                                                                                         fileright = True
                                                                                                                                                                                         cadmessage.Label7.Caption = "正在进行属性修改: 已找到         " & mainblock & " 当前正属性修改中。。。"
                                                                                                                                                                                         objatts = obj.GetAttributes
                                                                                                                                                                                         For m = LBound(objatts) To UBound(objatts)
                                                                                                                                                                                                                         For n = 0 To Combo6.ListCount - 1
                                                                                                                                                                                                                         If objatts(m).TagString = Combo6.List(n) Then
                                                                                                                                                                                                                                                         If Combo8.List(n)  "" Then
                                                                                                                                                                                                                                                         If Combo8.List(n) = "null" Or Combo8.List(n) = "NULL" Then
                                                                                                                                                                                                                                                         objatts(m).TextString = ""
                                                                                                                                                                                                                                                         Else
                                                                                                                                                                                                                                                         objatts(m).TextString = Combo8.List(n)
                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         Next n
                                                                                                                                                                                         Next m
                                                                                                                                                                                         End If
                                                                                                                                                         End If
                                                                                                                         Next obj
                                                         End If
                         End If
                         If fileright = False Then
                                                         Open VB.App.path & "\errlogolgj.txt" For Append As #1
                                                                                         Print #1, "*********************************************************************************"
                                                                                         Print #1, "打开文件出错:" & opendwgfile
                                                                                         Print #1, "属性修改未完成!未发现目标块 "
                                                                                         Print #1, Now
                                                                                         Print #1, "*********************************************************************************"
                                                         Close #1
                         End If
                         fileright = False
                         
                         '===================================
                         '===================================
                         '========如果有文件名修改任务=======
                         '===================================
                         '===================================
                         DoEvents
                         If Check10.Value = 1 Then
                         newdwgname = ""
                                                         '判断但前图形是否在模型空间中
                                                         If dwgfile.ActiveSpace = acModelSpace Then
                                                                                         '查早目标块
                                                                                         For Each obj In dwgfile.ModelSpace
                                                                                         '显示进程
                                                                                         cadmessage.Label7.Caption = "正在进行文件名提取: 查找目标块块 " & mainblock & " 当前 " & obj.ObjectName
                                                                                                                         '首先判断块类型是否为块属性
                                                                                                                         If obj.ObjectName = "AcDbBlockReference" Then
                                                                                                                                                         '再判断是否为要查找的目标块
                                                                                                                                                         If obj.Name = mainblock Then
                                                                                                                                                                                         fileright = True
                                                                                                                                                                                         '显示进程
                                                                                                                                                                                         cadmessage.Label7.Caption = "正在进行文件名提取: 已找到         " & mainblock & " 当前正属性提取中。。。"
                                                                                                                                                                                         '获取块属性集
                                                                                                                                                                                         objatts = obj.GetAttributes
                                                                                                                                                                                         For z = 1 To 20
                                                                                                                                                                                                                         If newfilename(z)  "" Then
                                                                                                                                                                                                                         If Mid(newfilename(z), 1, 5) = "const" Then
                                                                                                                                                                                                                                                         const1 = Right(newfilename(z), (Len(newfilename(z)) - 5))
                                                                                                                                                                                                                                                         newdwgname = newdwgname & const1
                                                                                                                                                                                                                         Else
                                                                                                                                                                                                                                                         For m = LBound(objatts) To UBound(objatts)
                                                                                                                                                                                                                                                                                         If objatts(m).TagString = newfilename(z) Then
                                                                                                                                                                                                                                                                                                                         newdwgname = newdwgname & objatts(m).TextString
                                                                                                                                                                                                                                                                                                                         Exit For
                                                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                                                         Next m
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                 Next z
                                                                                                                                                                                                                                                         
                                                                                                                                                         Exit For
                                                                                                                                                         End If
                                                                                                                         
                                                                                                                         End If
                                                                                 Next obj
                                                         End If
                                                         If dwgfile.ActiveSpace = acPaperSpace Then
                                                                                         '查早目标块
                                                                                         For Each obj In dwgfile.PaperSpace
                                                                                         '显示进程
                                                                                         cadmessage.Label7.Caption = "正在进行文件名提取: 查找目标块块 " & mainblock & " 当前 " & obj.ObjectName
                                                                                                                         '首先判断块类型是否为块属性
                                                                                                                         If obj.ObjectName = "AcDbBlockReference" Then
                                                                                                                                                         '再判断是否为要查找的目标块
                                                                                                                                                         If obj.Name = mainblock Then
                                                                                                                                                                                         '显示进程
                                                                                                                                                                                         fileright = True
                                                                                                                                                                                         cadmessage.Label7.Caption = "正在进行文件名提取: 已找到         " & mainblock & " 当前正属性提取中。。。"
                                                                                                                                                                                         '获取块属性集
                                                                                                                                                                                         objatts = obj.GetAttributes
                                                                                                                                                                                         For z = 1 To 20
                                                                                                                                                                                                                         If newfilename(z)  "" Then
                                                                                                                                                                                                                         If Mid(newfilename(z), 1, 5) = "const" Then
                                                                                                                                                                                                                                                         const1 = Right(newfilename(z), (Len(newfilename(z)) - 5))
                                                                                                                                                                                                                                                         newdwgname = newdwgname & const1
                                                                                                                                                                                                                         Else
                                                                                                                                                                                                                                                         For m = LBound(objatts) To UBound(objatts)
                                                                                                                                                                                                                                                                                         If objatts(m).TagString = newfilename(z) Then
                                                                                                                                                                                                                                                                                                                         newdwgname = newdwgname & objatts(m).TextString
                                                                                                                                                                                                                                                                                                                         Exit For
                                                                                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                                                         Next m
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                                         End If
                                                                                                                                                                                                 Next z
                                                                                                                                                                                                                                                         
                                                                                                                                                         Exit For
                                                                                                                                                         End If
                                                                                                                         
                                                                                                                         End If
                                                                                 Next obj
                                                         End If
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 16:22 , Processed in 1.290566 second(s), 56 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表