為什麼不顯示圖塊的value屬性,請管理員賜教

yuangw1234

程式如下，就是本人上次上传的东西现在再加了一些功能

现在本人有一个问题，就是我在图块上加了一些属性，其中的value为  "m"&ls

    Dim blockattr As AcadAttribute
    Set blockattr = blockobj.AddAttribute(2.5, acAttributeModeVerify, "ls", insertpoint,   "yuan", "m" & ls)
操作时确实是加了"m"&ls这个值,但是我要显示这个value（"m"&ls)却每次msgbox的是空内容（如下标示红色程式处），因为后面我要提出这个值来作为以后的自动标注，可是现在value都提不出来，为什么这样?望班竹,管理员或大师指教

Public pt1 As Variant
Public arc1 As AcadArc
Public ggregion As Variant
Public region1 As AcadRegion
Public region2 As AcadRegion
Public yj As Double
Public circ1 As AcadCircle
Public blockobj As AcadBlock
Public Blockrefobj As AcadBlockReference
Public insertpoint(0 To 2) As Double

Public Sub tt1()                                 
On Error Resume Next
Dim r  As Double
Dim sr As String
Dim zm As String
Dim Zm1 As String
Dim shuz As Double
Dim Shuz1 As Double
sr = InputBox("变化的东西", "变变", "")
zm = Mid(sr, 1, 1)
shuz = Mid(sr, 2)
Select Case zm
Case "m", "M"
    Call m(shuz)
    End Select
End Sub

Public Sub m(ls As Double)
On Error Resume Next
Dim ssetobj1 As AcadSelectionSet     
Dim selobj1 As AcadObject
Dim I As Integer
Dim I1 As Integer
ThisDrawing.SelectionSets("yuan").Delete
Err.Clear
Set ssetobj1 = ThisDrawing.SelectionSets.Add("yuan")
ThisDrawing.Utility.Prompt "please select object"
ssetobj1.SelectOnScreen
Const pi = 3.141592654
Set blockobj = ThisDrawing.Blocks("M" & ls)
If Err Then
    Err.Clear
    Set blockobj = ThisDrawing.Blocks.Add(insertpoint, "M" & ls)
    Dim blockattr As AcadAttribute
    Set blockattr = blockobj.AddAttribute(2.5, acAttributeModeVerify, "ls", insertpoint, "yuan", "m" & ls)
    Dim yj(14) As Double
    yj(5) = 4.3: yj(6) = 5.4: yj(8) = 6.8: yj(10) = 8.6: yj(12) = 10.5: yj(14) = 12.5
    Dim circ2 As AcadCircle
    Dim arc2 As AcadArc
    Set circ2 = blockobj.AddCircle(insertpoint, yj(ls) / 2)
    circ2.Linetype = "CONTINUOUS"
    Set arc2 = blockobj.AddArc(insertpoint, ls / 2, pi, pi / 2)
    arc2.Linetype = "CONTINUOUS"
End If
Dim pt(0 To 2) As Variant
pt(0) = pt(1) = pt(2) = Null
For I = 0 To ssetobj1.Count - 1
Set selobj1 = ssetobj1.Item(I)
Select Case selobj1.ObjectName
    Case "AcDbCircle", "AcDbArc"
    Dim pta As Variant
    pta = selobj1.Center
    If pta(0) = pt(0) And pta(1) = pt(1) And pta(2) = pt(2) Then
    selobj1.Delete
    Else
    pt(0) = pta(0)
    pt(1) = pta(1)
    pt(2) = pta(2)
    selobj1.Delete
    Blockrefobj = ThisDrawing.ModelSpace.InsertBlock(pta, "M" & ls, 1#, 1#, 1#, 0)
    Dim str13 As Variant
    str13 = Blockrefobj.GetAttributes
    Dim Str14 As String
    Str14 = str13(0).TextString
    MsgBox Str14
    End If
    Case "AcDbBlockReference"
    selobj1.Name = "M" & ls
    selobj1.Update
    Case "AcDbLine", "AcDbPolyline"
    Dim shu As Integer
    shu = MsgBox("输入错误", 1 + 16, "确认")
    Select Case shu
    Case 2
    Exit Sub
    End Select
 End Select
 Next
       

End Sub

yuangw1234

大师们呢？为什么没有人回复呢？郁闷

yuangw1234

斑竹，可以请教你吗？为什么到现在都没有人可以帮忙，只好麻烦斑竹了，多谢!!

雪山飞狐_lzh

默认字符在VBA插入块时不会起作用

你要在插入块时向属性引用直接赋值

yuangw1234

4楼的大师可否将本人程式改一改以实现本人的目的，谢谢

有可以帮忙的都感谢你们

yuangw1234

4楼的版主可否说细一点，帮本菜鸟动一下程式，因为我看 autocad上的帮助和我写的基本一样（稍变了一下而已），但它的可以，而我的不可以，闷！！！！

雪山飞狐_lzh

在str13 = Blockrefobj.GetAttributes后面直接对属性引用赋值

yuangw1234

这个问题我搞定了，是我的整个程式少了三个字