急急急 由块名得到块中的所有属性
急急急 由块名得到块中的所有属性 '==================================='===================================
'========如果有属性修改任务=========
'===================================
'===================================
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
页:
[1]