為什麼不顯示圖塊的value屬性,請管理員賜教
本帖最后由 作者 于 2006-4-18 12:38:31 编辑 <br /><br /> <P>程式如下，就是本人上次上传的东西现在再加了一些功能</P><P>现在本人有一个问题，就是我在图块上加了一些属性，其中的value为 "m"&ls</P>
<P> Dim blockattr As AcadAttribute<BR> Set blockattr = blockobj.AddAttribute(2.5, acAttributeModeVerify, "ls", insertpoint, "yuan", "m" & ls)<BR>操作时确实是加了"m"&ls这个值,但是我要显示这个value（"m"&ls)却每次msgbox的是空内容（如下标示红色程式处），因为后面我要提出这个值来作为以后的自动标注，可是现在value都提不出来，为什么这样?望班竹,管理员或大师指教</P>
<P>Public pt1 As Variant<BR>Public arc1 As AcadArc<BR>Public ggregion As Variant<BR>Public region1 As AcadRegion<BR>Public region2 As AcadRegion<BR>Public yj As Double<BR>Public circ1 As AcadCircle<BR>Public blockobj As AcadBlock<BR>Public Blockrefobj As AcadBlockReference<BR>Public insertpoint(0 To 2) As Double</P>
<P>Public Sub tt1() <BR>On Error Resume Next<BR>Dim r As Double<BR>Dim sr As String<BR>Dim zm As String<BR>Dim Zm1 As String<BR>Dim shuz As Double<BR>Dim Shuz1 As Double<BR>sr = InputBox("变化的东西", "变变", "")<BR>zm = Mid(sr, 1, 1)<BR>shuz = Mid(sr, 2)<BR>Select Case zm<BR>Case "m", "M"<BR> Call m(shuz)<BR> End Select<BR>End Sub<BR></P>
<P>Public Sub m(ls As Double)<BR>On Error Resume Next<BR>Dim ssetobj1 As AcadSelectionSet <BR>Dim selobj1 As AcadObject<BR>Dim I As Integer<BR>Dim I1 As Integer<BR>ThisDrawing.SelectionSets("yuan").Delete<BR>Err.Clear<BR>Set ssetobj1 = ThisDrawing.SelectionSets.Add("yuan")<BR>ThisDrawing.Utility.Prompt "please select object"<BR>ssetobj1.SelectOnScreen<BR>Const pi = 3.141592654<BR>Set blockobj = ThisDrawing.Blocks("M" & ls)<BR>If Err Then<BR> Err.Clear<BR> Set blockobj = ThisDrawing.Blocks.Add(insertpoint, "M" & ls)<BR> Dim blockattr As AcadAttribute<BR> Set blockattr = blockobj.AddAttribute(2.5, acAttributeModeVerify, "ls", insertpoint, "yuan", "m" & ls)<BR> Dim yj(14) As Double<BR> yj(5) = 4.3: yj(6) = 5.4: yj(8) = 6.8: yj(10) = 8.6: yj(12) = 10.5: yj(14) = 12.5<BR> Dim circ2 As AcadCircle<BR> Dim arc2 As AcadArc<BR> Set circ2 = blockobj.AddCircle(insertpoint, yj(ls) / 2)<BR> circ2.Linetype = "CONTINUOUS"<BR> Set arc2 = blockobj.AddArc(insertpoint, ls / 2, pi, pi / 2)<BR> arc2.Linetype = "CONTINUOUS"<BR>End If<BR>Dim pt(0 To 2) As Variant<BR>pt(0) = pt(1) = pt(2) = Null<BR>For I = 0 To ssetobj1.Count - 1<BR>Set selobj1 = ssetobj1.Item(I)<BR>Select Case selobj1.ObjectName<BR> Case "AcDbCircle", "AcDbArc"<BR> Dim pta As Variant<BR> pta = selobj1.Center<BR> If pta(0) = pt(0) And pta(1) = pt(1) And pta(2) = pt(2) Then<BR> selobj1.Delete<BR> Else<BR> pt(0) = pta(0)<BR> pt(1) = pta(1)<BR> pt(2) = pta(2)<BR> selobj1.Delete<BR> Blockrefobj = ThisDrawing.ModelSpace.InsertBlock(pta, "M" & ls, 1#, 1#, 1#, 0)<BR> <FONT color=#ff0000> Dim str13 As Variant<BR> str13 = Blockrefobj.GetAttributes<BR> Dim Str14 As String<BR> Str14 = str13(0).TextString<BR> MsgBox Str14<BR></FONT> End If<BR> Case "AcDbBlockReference"<BR> selobj1.Name = "M" & ls<BR> selobj1.Update<BR> Case "AcDbLine", "AcDbPolyline"<BR> Dim shu As Integer<BR> shu = MsgBox("输入错误", 1 + 16, "确认")<BR> Select Case shu<BR> Case 2<BR> Exit Sub<BR> End Select<BR> End Select<BR> Next<BR> </P>
<P>End Sub</P> 大师们呢？为什么没有人回复呢？郁闷 斑竹，可以请教你吗？为什么到现在都没有人可以帮忙，只好麻烦斑竹了，多谢!! <P>默认字符在VBA插入块时不会起作用</P>
<P>你要在插入块时向属性引用直接赋值</P> <P>4楼的大师可否将本人程式改一改以实现本人的目的，谢谢</P>
<P>有可以帮忙的都感谢你们</P> 4楼的版主可否说细一点，帮本菜鸟动一下程式，因为我看 autocad上的帮助和我写的基本一样（稍变了一下而已），但它的可以，而我的不可以，闷！！！！ 在<FONT color=#ff0000>str13 = Blockrefobj.GetAttributes后面直接对属性引用赋值</FONT> <P>这个问题我搞定了，是我的整个程式少了三个字</P>
<P> </P>
页:
[1]