VBA高手请帮忙

poly168

请VBA高手将这个LISP改写成VBA，急用。不胜感谢 defun dstbm ()
(setq mm (entlast))
(setq pb (entget mm))
(regapp "SOUTH")
(setq
xb
(append
pb
(list
(list '-3
(list "SOUTH" (cons 1000 stbmx))
)
)
)
)
(entmod xb)
(princ)
) ;;;批量展测量点
(defun c:zdtxt (/ l wzcl wzch l3 oldcmd oldblip oldsnap tckz newlayer fle fn pt dm zb xyz h lscale xyz1 xyz2)
(setq l (getvar "ltscale"))
(setq wzcl (* l 2))
(setq wzch (* l 2))
(setq l3 (angle (getvar "ucsorg")
(getvar "ucsxdir")
)
)
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq oldblip (getvar "blipmode"))
(setvar "blipmode" 0)
(setq oldsnap (getvar "osmode"))
(setvar "osmode" 0)
(setvar "angdir" 1)
(setq fle (getfiled "请选择数据文件"
"*"
"txt;dat;*"
2
)
)
(if (= (tblobjname "layer" "GCD") nil)
(progn
(command "layer" "n" "zd" "C" "1" "GCD" "")
)
)
(setq fn (open fle "r"))
(read-line fn)
(setq n 0)
(while (setq pt (read-line fn))
(setq dm (vl-princ-to-string (read pt)))
(setq zb (substr pt (+ (strlen dm) 1)))
(setq
xyz (trans (read (strcat "(" zb ")"))
1
0
)
)
(setq h (rtos (last xyz) 2 1))
(setq lscale (* l 1))
(entmake
(list (cons 0 "INSERT")
(cons 100 "AcDbEntity")
(cons 8 "GCD")
(cons 100 "AcDbBlockReference")
(cons 10 xyz)
(cons 41 lscale)
(cons 42 lscale)
(cons 43 lscale)
(cons 410 "model")
(cons 2 "gc200")
)
) ;"gc200"为块名
(setq stbmx (itoa 202101))
(dstbm)
(setq xyz1
(polar xyz (/ pi 2) (* l 2))
)
(setq xyz2
(polar xyz (* (/ pi 2) 3) (* l 2))
)
(entmake (list (cons 0 "Text")
(cons 100 "AcDbEntity")
(cons 8 "GCD")
(cons 100 "AcDbText")
(cons 7 "standard")
(cons 1 dm)
(cons 40 wzcl)
(cons 41 0.8)
(cons 410 "model")
(cons 71 0)
(cons 72 4)
(cons 73 0)
(cons 10 xyz1)
(cons 11 xyz1)
)
)
(setq stbmx (itoa 202111))
(dstbm)
(entmake (list (cons 0 "Text")
(cons 100 "AcDbEntity")
(cons 8 "GCD")
(cons 100 "AcDbText")
(cons 7 "hz")
(cons 1 h)
(cons 40 wzch)
(cons 41 0.8)
(cons 410 "model")
(cons 71 0)
(cons 72 4)
(cons 73 0)
(cons 10 xyz2)
(cons 11 xyz2)
)
)
(setq stbmx (itoa 202111))
(dstbm)
(setq n (+ n 1))
)
(if (= pt nil)
(progn
(alert (strcat "*--*展点结束，共展"
(itoa n)
"个点*--*!。"
)
)
(setvar "cmdecho" oldcmd)
(setvar "blipmode" oldblip)
(setvar "osmode" oldsnap)
(setvar "angdir" 1)
(setvar "clayer" "0")
)
)
(close fn)
(command "zoom" "E")
(princ)
)