请求论坛lisp高手帮帮忙

sibelle_hu

请论坛lisp高手帮忙写个带字母箭头的程序，不胜感激！
方向如上图所示，字母总是在箭头上方，两点画箭头，先拾取一点，放置箭头的尾部，指定第二点放置箭头，类似于画直线，指定第一点后，会从第一点到鼠标指针引一条线
另外，字母可以输入其它，字高可以改变，箭头大小等于字高，箭头带线总长度等于４倍的字高


该贴已经同步到 sibelle_hu的微博

sibelle_hu

在本论坛和百度上找了好久,都没有一个像样点的箭头绘制程序,请高手出马啊 !

sibelle_hu

终于找了一个箭头的绘制程序，高手能帮我改一改吗？

2. (defun c:Arrow (/ a b)
   
3.   ;; Draw quick arrow
   
4.   ;; Alan J. Thompson
   
5.   (if (and (setq a (getpoint "\nSpecify first point: "))
   
6.            (setq b (getpoint a "\nSpecity next point: "))
   
7.       )
   
8.     (command "_.leader" "_non" a "_non" b "" "" "_N")
   
9.   )
   
10.   (princ)
    
11. )

(defun c:Arrow (/ a b)<br />   ;; Draw quick arrow<br />   ;; Alan J. Thompson<br />   (if (and (setq a (getpoint "\nSpecify first point: "))<br />            (setq b (getpoint a "\nSpecity next point: "))<br />       )<br />     (command "_.leader" "_non" a "_non" b "" "" "_N")<br />   )<br />   (princ)<br /> )

xyp1964

sibelle_hu

大师，玩不转呀，演示非常不错，缺少xyp开头的几个自定义函数，看说明是不是要装e派工具箱？还要注册？

ZZXXQQ

2. (defun c:tt ()
   
3. (setvar "CMDECHO" 0)
   
4. (setq txt (getstring "\n标注内容: "))
   
5. (while (and (setq pt1 (getpoint "\n起点: "))
   
6.              (setq pt2 (getpoint pt1 "\n终点: ")))
   
7. (setq dis (distance pt1 pt2)
   
8.        ang (angle pt1 pt2)
   
9.        ang2 (angle pt2 pt1)
   
10.        ll (/ dis 4)
    
11.        dd (/ dis 10)
    
12.        ptm (mapcar '(lambda(a b) (/ (+ a b) 2)) pt1 pt2))
    
13. (setq ang1 (if (< (/ (* pi 2) 3) ang (/ (* pi 5) 3)) pi 0))
    
14. (setq an (+ ang (/ pi 2) ang1))
    
15. (command "_.PLINE" pt1 (polar pt2 ang2 ll) "W" dd 0 pt2 "")
    
16. (if (/= txt "")
    
17. (command "_.TEXT" "TC" (polar ptm an ll) dd (/ (* (- an (/ pi 2)) 180) pi) txt)
    
18. )
    
19. )
    
20. (setvar "CMDECHO" 1)
    
21. (princ)
    
22. )
    

(defun c:tt ()<br /> (setvar "CMDECHO" 0)<br /> (setq txt (getstring "\n标注内容: "))<br /> (while (and (setq pt1 (getpoint "\n起点: "))<br />              (setq pt2 (getpoint pt1 "\n终点: ")))<br /> (setq dis (distance pt1 pt2)<br />        ang (angle pt1 pt2)<br />        ang2 (angle pt2 pt1)<br />        ll (/ dis 4)<br />        dd (/ dis 10)<br />        ptm (mapcar '(lambda(a b) (/ (+ a b) 2)) pt1 pt2))<br /> (setq ang1 (if (< (/ (* pi 2) 3) ang (/ (* pi 5) 3)) pi 0))<br /> (setq an (+ ang (/ pi 2) ang1))<br /> (command "_.PLINE" pt1 (polar pt2 ang2 ll) "W" dd 0 pt2 "")<br /> (if (/= txt "")<br /> (command "_.TEXT" "TC" (polar ptm an ll) dd (/ (* (- an (/ pi 2)) 180) pi) txt)<br /> )<br /> )<br /> (setvar "CMDECHO" 1)<br /> (princ)<br /> )<br />

sibelle_hu

ZZXXQQ 发表于 2014-8-11 08:26

感谢超版的帮忙，还有点问题，就是现在是靠拾取两点间的长度来定箭头大小与字母大小，我要的是，运行程序后可以设定字高，箭头大小等于字高，箭头带线总长度等于４倍的字高，也就是说拾取的两点并不能决定箭头的总长，因为设定字高后，总长就以经定下来了，拾取的第二点只是定箭头的方向。

恕放之生命

学习一下。

77077

我觉着吧,做成块更方便些,主要是方便以后读取数据,批量修改大小等~~~

zhangcan0515

谢谢你的向视图符号