[编程申请]：斑竹现在在吗？急求LISP程序

thx

真是书到用时方恨少！！今天碰到一个难题，生成DEM转为DWG时，高程点精度只有小数点后一位，但是设计要求2位，由于高程点的值也是一位，希望斑竹和各位大虾帮我编一个小小的LISP程序，能批量随机地把高程点和高程点注记加注到小数点后第2位，比如：高程注记为13.20，运行LISP后随机的改为13.21或者13.22等，高程点和高程注记的Z值也随之改变。我知道这个程序很容易写出来，可惜我还不会，如果哪位大虾今天晚上或者明天能把LISP发上来，真是感激不尽。谢了

自由的鱼

VBA程序要吗？如果要的话就发张图上来！

thx

谢谢107309 ，只要能实现，当然要，太感谢你了，你等一下，别走，我马上去找来发，现在发上去DXF，你看一下

eachy

最初由 thx 发布
[B]谢谢107309 ，只要能实现，当然要，太感谢你了，你等一下，别走，我马上去找来发，现在发上去DXF，你看一下 [/B]

1 缺少 shp 文件，dxf 无法加载
2 你这个精度有没有范围，13.0 -〉13.1、13.2、13.3、 。。。

自由的鱼

提示图形无效，打不开！

thx

感谢斑竹和自由的鱼，不知道你们现在还在吗？我现在重新传一下，刚才DXF我是在挂了MAPDRAW的情况输出的，所以缺少SHX，现在应该可以了，麻烦你们再看一下，斑竹刚才说的精度，比如13.3，随机加到第二位后可以是13.31到13.39，也就是说在0.01-0.09之间都可以。

雪山飞狐(lzh)

[Code]Sub Testavc()
On Error GoTo ErrHandle
Dim ss As AcadSelectionSet
Dim ft(0) As Integer, fd(0)
Dim i As AcadPoint
Dim j As AcadText
Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
ft(0) = 0
fd(0) = "Point"
ss.Select acSelectionSetAll, , , ft, fd
For Each i In ss
a = i.Coordinates
a(2) = a(2) + 0.01
i.Coordinates = a
Next i
ss.Clear
fd(0) = "Text"
ss.Select acSelectionSetAll, , , ft, fd
For Each j In ss
j.TextString = str(Val(j.TextString) + 0.01)
Next j
ErrHandle:
On Error Resume Next
ThisDrawing.SelectionSets("*TlsTest*").Delete
End Sub
[/Code]
没有考虑图层因素，需要考虑麽？

thx

请问一下斑竹lzh741206，这是VBA程序吗？对VBA我更不熟悉，是不是保存到记事本，后缀名是DVB，然后在CAD下输入‘LOADVBA”，运行即可，如果不是，请详细告诉我一下怎么用？

雪山飞狐(lzh)

工具－>宏－>VB编辑器
双击左边的ThisDrawing图标
在右边的代码窗口把上面代码Copy进去
运行-vbarun命令
输入Testavc

自由的鱼

来晚了，在AUTOCAD的命令行中输入VBAIDE，然后把代码COPY进去，点击运行就可以了！记得运行的时候要缩放全图！你发的那个图改好了，看看是不是你要求的那样！有问题再告诉我吧！
Option Explicit

Sub tt()
Dim pobj As AcadPoint
Dim sset As AcadSelectionSet
Dim tset As AcadSelectionSet
Dim i As Integer
Dim Ftype(1) As Integer
Dim Fdata(1) As Variant
Dim Coord As Variant
Dim Ncoord(0 To 2) As Double

Dim TMP As Double
Dim minpnt(0 To 2) As Double
Dim maxpnt(0 To 2) As Double
Ftype(0) = 0
Fdata(0) = "POINT"

Ftype(1) = 8
Fdata(1) = "832"
Set tset = ThisDrawing.SelectionSets.Add("t")
Set sset = ThisDrawing.SelectionSets.Add("tt")
sset.Select acSelectionSetAll, , , Ftype, Fdata
For Each pobj In sset
    Coord = pobj.Coordinates
    TMP = Int(9 * Rnd() + 1) * 0.01
    Ncoord(0) = Coord(0)
    Ncoord(1) = Coord(1)
    Ncoord(2) = Coord(2) + TMP
    minpnt(0) = Coord(0) - 1
    minpnt(1) = Coord(1) - 2
    minpnt(2) = 0
    maxpnt(0) = Coord(0) + 5
    maxpnt(1) = Coord(1) + 3
    maxpnt(2) = 0
    tset.Select acSelectionSetWindow, minpnt, maxpnt
    tset.Item(0).TextString = Ncoord(2)
    pobj.Coordinates = Ncoord
    pobj.Update
    tset.Clear
Next
sset.Delete
End Sub

thx

斑竹帮我写的程序运行后所有的都是加0.01，自由的鱼帮我写的程序我就运行了一次成功，再运行的时候总是提示选择集已经存在，这是为什么？我重新复制了也不行，你还在吗？帮我解答一下，非常感谢二位

雪山飞狐(lzh)

Sub Testavc()
On Error GoTo ErrHandle
Dim ss As AcadSelectionSet
Dim tss As AcadSelectionSet
Dim ft(0) As Integer, fd(0)
Dim pnt, a
Dim tmp As Double
Dim i As AcadPoint
Dim j As AcadText
Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
Set tss = ThisDrawing.SelectionSets.Add("*TlsText*")
ft(0) = 0
fd(0) = "Point"
ss.Select acSelectionSetAll, , , ft, fd
For Each i In ss
tmp = Int(9 * Rnd() + 1) * 0.01
a = i.Coordinates
pnt = a
pnt(1) = pnt(1) - 0.5
pnt(2) = 0
ft(0) = 10
fd(0) = pnt
tss.Clear
tss.Select acSelectionSetAll, , , ft, fd
a(2) = a(2) + tmp
i.Coordinates = a
If tss.Count = 1 Then tss(0).TextString = " " & Format(a(2), "####.##")
Next i
ss.Clear
ErrHandle:
On Error Resume Next
ThisDrawing.SelectionSets("*TlsText*").Delete
ThisDrawing.SelectionSets("*TlsTest*").Delete
End Sub

自由的鱼

最初由 thx 发布
[B]斑竹帮我写的程序运行后所有的都是加0.01，自由的鱼帮我写的程序我就运行了一次成功，再运行的时候总是提示选择集已经存在，这是为什么？我重新复制了也不行，你还在吗？帮我解答一下，非常感谢二位 [/B]

让我看看，这么奇怪！

雪山飞狐(lzh)

鱼，你少个tset.Delete

thx

感谢斑竹，这下程序好用了，也非常感谢自由的鱼，你们只用简单的几个语句就帮我解决了大问题，得向你们学习，我也想学学LISP，VBA，可惜一直都没有时间，这下我是没时间我也抽时间出来学了，想请问一下：如果这个程序用LISP来实现的话，是不是比用VBA要复杂？也就是说是不是学VBA要比LISP更实用，但VBA要比LISP难学？