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

singlewolf 发表于 2004-12-23 17:06:00

CLARKLEE 发表于 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, "属性修改未完成！未发现目标块 <" & mainblock & ">" 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

页: [1]

明经CAD社区's Archiver

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

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