求lsp 程序？？？

水的畅想

2006年07月29日 17:53:45

2楼

我这边有一个
不过不是LISP
改天给里传上来吧

elevenheart

2006年07月31日 12:05:56

3楼

先谢谢了！哈哈

xshrimp

2006年07月31日 22:22:02

4楼

用我签名下的工具,命令wq即可断线插字。

水的畅想

2006年08月01日 11:19:36

5楼

;;;GX 为管线注字程序适用于 line polyline lwpolyline 线型2003,2,18;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:GX ()

(SETQ OLLAY (GETVAR "CLAYER"))
(SETQ OTS (GETVAR "TEXTSTYLE"))
(setq blk (getreal "\n 请输入出图比例(只输入分母) <100>"))
(if (= blk nil)
(setq blk 100)
) ;_ end of if
(setq zig1 3)
(princ "\n 原字高为:")
(princ zig1)
(setq zig2 (getreal " 请输入字高(图纸上, mm) <原高> "))
(if (= zig2 nil)
(setq zig2 zig1)
) ;_ 结束if
(setq zig (* zig2 blk))
(setq zig1 zig)
(princ "\n 原管线代号为:")
(princ gxdh1)
(setq gxdh (getstring " 请输入管线代号<原代号> "))
(if (= gxdh "")
(setq gxdh gxdh1)
) ;_ 结束if
(setq gxdh1 gxdh)
(SETQ ZIL (STRLEN GXDH))
(SETQ ZIL1 (/ (* ZIL ZIG) 2))
(setvar "osmode" 8)

(setq aa0 nil)
(while (= aa0 nil)
(setq aa0 (entsel "\n 请点取注字点"))
) ;_ 结束while
(setq aa01 (cdr aa0))
(setq aa1 (car aa01))
(SETQ AA101 (ENTGET (CAR AA0)))
(setq ca1 (assoc 8 AA101))
(SETQ CA10 (CDR CA1))
(setq pt2 (osnap aa1 "nea"))
(setq ang2 (angle pt2 aa1))
(setq bb 0)
(while (= bb 0)
(setvar "osmode" 0)
(setq ang (- ang2 (/ pi 2)))
(setq aa3 (polar PT2 ang ZIL1))
(setq aa4 (polar PT2 (+ pi ang) ZIL1))
(command "break" aa3 aa4)
(setvar "osmode" 0)
(IF (EQUAL ANG2 0 0.08)
(setq ang2 pi)
) ;_ 结束IF
(setq ang (- ang2 (/ pi 2)))
(while (> ang (+ (/ pi 2.0) 0.08))
(setq ang (- ang pi))
) ;_ end of while
(setq ang1 (* (/ ang pi) 180.0))
(command "LAYER" "s" CA10 "")
(command "text" "justify" "MIDDLE" PT2 ZIG ang1 gxdh)
(command "LAYER" "s" OLLAY "")
(setvar "osmode" 8)
(setq aa0 nil)
(while (= aa0 nil)
(setq aa0 (entsel "\n 请点取注字点(ESC 结束)"))
) ;_ 结束while
(setq aa01 (cdr aa0))
(setq aa1 (car aa01))
(SETQ AA101 (ENTGET (CAR AA0)))
(SETQ CA10 (CDR CA1))
(setvar "osmode" 0)
(setq pt2 (osnap aa1 "nea"))
(setq ang2 (angle pt2 aa1))
;;(setvar "osmode" 512)
;;(setq pt1 (osnap (setq aa1 (osnap (getpoint "\n 请点取注字点,继续 <回车结束>") "nea")) "end"))
;;(if (= aa1 nil)
;; (setq bb 1)
;; ) ;_ end of if
) ;_ end of while
(SETVAR "TEXTSTYLE" OTS)
(princ)
(SETOLD)
) ;_ end of defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

水的畅想

2006年08月01日 11:21:32

6楼

是从别人的软件上摘抄下来的,
加载以后输入GX即可调用该命令了

elevenheart

2006年08月01日 11:58:44

7楼

六楼的，太感谢了！向你学习，哈哈！

elevenheart

2006年08月01日 12:16:00

8楼

程序中的第二行的(GETOLD)好像有问题，加载后出现错误！