版主给我开通进入cad博客的权限吧,我贡献一个修改数字的程序
'此程序在cad2002上测试通过,cad2006上须改动" If Val(TXTSTR) <> 0 And WS = "2" Then" 为"If Val(TXTSTR) = 0"Public Sub modify_GC()Dim SSETS As AcadSelectionSet
'Dim Element As Object
'Dim ENTITY As AcadEntity
Dim entity As AcadEntity ';定义为Object或ACADObject或AcadEntity都可以，但有区别！
Dim GCTET As String
Dim gcdlayer As AcadLayer
Dim gzz As Double
'Dim WS As String '小数点位数
'Set gcdlayer = ThisDrawing.Layers.Item("Gcd")
'MsgBox "jtgjj"
On Error Resume Next
' WS = InputBox("请输入小数点位数，默认为2位：", , "2")
gzz = InputBox("*****请输入改正值,默认为0：*****", , "0")
If Not IsNull(ThisDrawing.SelectionSets.Item("GCDSET")) Then
Set SSETS = ThisDrawing.SelectionSets.Item("GCDSET")
SSETS.Delete
End If
Set SSETS = ThisDrawing.SelectionSets.Add("GCDSET")
'Set ssets = ThisDrawing.SelectionSets.Add("SSET")
SSETS.Select acSelectionSetAll
For Each entity In SSETS
'If ENTITY.ObjectName = "AcDbText" Then
TXTSTR = entity.TextString
If Val(TXTSTR) <> 0 And WS = "2" Then
entity.TextString = Format((Val(TXTSTR) + Val(gzz)), "0.00")
Else: entity.TextString = Format((Val(TXTSTR) + Val(gzz)), "0.0")
If entity.ObjectName = "AcDbText" Then
entity.color = acGreen + acRed
entity.Update
End If
End If
'MsgBox entity.ObjectName
'entity.Highlight
' MsgBox ENTITY '
'currentspace = ThisDrawing.ActiveSpace
'GCTEXT = Element.TextString
'If Val(ENTITY) <> 0 Then
'ENTITY = Format(ENTITY, "0.0")
'ENTITY.Update
'
' End If
Next
MsgBox "数据修改完毕！"
Exit Sub
MsgBox "出问题啦！"
End Sub
<P>过段时间升级了服务器再说吧，目前网站空间不够用，暂时不考虑申请。</P>
<P>程序应考虑更大的给用户的灵活性,而你的程序只给用户保留小数后一位或两位的功能，不能再有其它，明显还不够灵活。希望再改进。</P> <P><FONT color=#008000>要想改变小数点位数只要把下面的" ' "删掉即可,用户可以在<FONT color=#0000ff>InputBox中</FONT>输入要保留的小数位数</FONT></P>
<P><FONT color=#008000>' WS </FONT><FONT color=blue>=</FONT><FONT color=#008000> </FONT><FONT color=blue>InputBox</FONT><FONT color=red>(</FONT><FONT color=#880000>"请输入小数点位数，默认为2位："</FONT><FONT color=#008000>, , </FONT><FONT color=#880000>"2"</FONT><FONT color=red>)</FONT><BR></P>
页:
[1]