sibelle_hu 发表于 2014-8-8 16:19:47

请问用lisp能不能画这样的图？



我知道像这样的情况可以用块做出来，不知道用lisp能不能行？有没有高手愿意帮我写个？

弧的半径可以设定，根据设定的半径绘制，拾取点为圆弧的中心，箭头的长度等于圆弧半径的一半，箭头的宽度等于三分之一的箭头长，箭头角度为20度左右


http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 sibelle_hu的微博

Q1241274614 发表于 2014-8-8 16:51:07

你可以参考一下大师的程序 http://lee-mac.com/arrowarc.html

sibelle_hu 发表于 2014-8-8 16:57:51

谢谢，lisp我不会，刚学会怎么使用lisp程序，这个程序可以画弧形的箭头，可是与我的要求有很多差别的

edata 发表于 2014-8-8 17:30:37

;; Arc to Bulge-Lee Mac
;; c   - center
;; a1,a2 - start, end angle
;; r   - radius
;; Returns: (<vertex> <bulge> <vertex>)

(defun LM:Arc->Bulge ( c a1 a2 r )
    (list
      (polar c a1 r)
      (   (lambda ( a ) (/ (sin a) (cos a)))
            (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
      )
      (polar c a2 r)
    )
)
;;绘制圆弧 pt 圆心r 半径 ang1 起始弧度 ang2 结束弧度 l_lay 图层 l_col 颜色 l_lt 线型 l_lts 线型比例 l_lw 线宽
;;(sk_mk_arc01 pt r ang1 ang2 l_lay l_col l_lt l_lts l_lw)
(defun sk_mk_arc01(pt r ang1 ang2 l_lay l_col l_lt l_lts l_lw)
(if(and pt r ang1 ang2)
    (entmakex (list '(0 . "ARC")
                  (cons 8 (if l_lay l_lay (getvar 'clayer)))
                  (if l_col (cons 62 l_col)(cons 62 256))
                  (if l_lt (cons 6 l_lt)(cons 6 "bylayer"))
                  (cons 48 (if l_lts l_lts (getvar 'celtscale)))
                  (if l_lw (cons 370 l_lw)(cons 370 0))
                  (cons 10 pt)
                  (cons 40 r)
                  (cons 50 ang1)
                  (cons 51 ang2)
                  )
                  )
    )
)

(defun c:tt(/ANG1 ARC_LEN EN L OBJ P1 P2 PT R W ANG2 BULGE P3)
(if(and (setq r(getdist "\n半径:"))
          (setq pt(getpoint "\n圆心:"))
          )
    (progn
      (setq l(* 0.5 r))
      (setq w(/ l 3.0))
      (setq en(sk_mk_arc01 pt r 0 pi nil nil nil nil nil))
      (setq obj(vlax-ename->vla-object en))
      (setq arc_len(vla-get-arclength obj))
      (setq p1(vlax-curve-getstartpoint obj))
      (setq p2(vlax-curve-getPointAtDist obj (- arc_len l)))
      (setq p3(vlax-curve-getEndpoint obj))      
      (setq ang1(angle pt p2 ))
      (setq ang2 0)
      (setq bulge(cadr(LM:Arc->Bulge pt ang2 ang1 r)))
      (vla-delete obj)      
      (entmakex (list '(0 . "LWPOLYLINE")
                      '(100 . "AcDbEntity")
                      '(100 . "AcDbPolyline")
                      (cons 90 3)
                      (cons 10 p1)
                      (cons 42 bulge)
                      (cons 10 p2)
                      (cons 40 w)
                      (cons 41 0)                     
                      (cons 10 p3)))
      )
    )
(princ)
)

lucas_3333 发表于 2014-8-8 18:16:19

本帖最后由 lucas_3333 于 2014-8-8 18:17 编辑

edata 发表于 2014-8-8 17:30 static/image/common/back.gif

Ｅ大，厉害！乐于助人！明经的活雷锋！

sibelle_hu 发表于 2014-8-8 18:19:36

谢谢大师，请问能不能再帮忙加个选项？即输入Ｌ，箭头就在左侧，输入Ｒ箭头就在右侧？

sibelle_hu 发表于 2014-8-8 20:21:33

edata 发表于 2014-8-8 17:30 static/image/common/back.gif


大师，能不能也帮帮我这个问题？
http://bbs.mjtd.com/thread-111031-1-1.html

edata 发表于 2014-8-8 20:35:09

;; Arc to Bulge-Lee Mac
;; c   - center
;; a1,a2 - start, end angle
;; r   - radius
;; Returns: (<vertex> <bulge> <vertex>)

(defun LM:Arc->Bulge ( c a1 a2 r )
    (list
      (polar c a1 r)
      (   (lambda ( a ) (/ (sin a) (cos a)))
            (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
      )
      (polar c a2 r)
    )
)
;;绘制圆弧 pt 圆心r 半径 ang1 起始弧度 ang2 结束弧度 l_lay 图层 l_col 颜色 l_lt 线型 l_lts 线型比例 l_lw 线宽
;;(sk_mk_arc01 pt r ang1 ang2 l_lay l_col l_lt l_lts l_lw)
(defun sk_mk_arc01(pt r ang1 ang2 l_lay l_col l_lt l_lts l_lw )
(if(and pt r ang1 ang2)
    (entmakex (list '(0 . "ARC")
                  (cons 8 (if l_lay l_lay (getvar 'clayer)))
                  (if l_col (cons 62 l_col)(cons 62 256))
                  (if l_lt (cons 6 l_lt)(cons 6 "bylayer"))
                  (cons 48 (if l_lts l_lts (getvar 'celtscale)))
                  (if l_lw (cons 370 l_lw)(cons 370 0))
                  (cons 10 pt)
                  (cons 40 r)
                  (cons 50 ang1)
                  (cons 51 ang2)
                  )
                  )
    )
)

(defun c:tt(/ANG1 ARC_LEN EN L OBJ P1 P2 PT R W ANG2 BULGE P3 keys)
(or *sk_rad_jt001* (setq *sk_rad_jt001* 10.0))
(setq *sk_rad_jt001*(cond((getdist (strcat "\n输入半径<" (rtos *sk_rad_jt001* 2 4) ">:")))(*sk_rad_jt001*)))
(princ (strcat "\r当前半径<" (rtos *sk_rad_jt001* 2 4) ">:"))
(if(setq pt(getpoint "\n圆心:"))
    (progn
      (setq r *sk_rad_jt001*)
      (initget "L R _l r")      
      (setq keys(cond((getkword "\r输入左右方向<L>: "))("l")))
      (setq l(* 0.5 r))
      (setq w(/ l 3.0))
      (setq en(sk_mk_arc01 pt r 0 pi nil nil nil nil nil))
      (setq obj(vlax-ename->vla-object en))
      (setq arc_len(vla-get-arclength obj))
      (setq p1(if (= keys "l") (vlax-curve-getstartpoint obj) (vlax-curve-getEndpoint obj)))
      (setq p2(vlax-curve-getPointAtDist obj (if (= keys "l") (- arc_len l) l)))
      (setq p3(if (= keys "l") (vlax-curve-getEndpoint obj)(vlax-curve-getstartpoint obj) ))      
      (setq ang1(angle pt p2 ))
      (setq ang2 (if (= keys "l") 0 pi ))
      (setq bulge(cadr(LM:Arc->Bulge pt (if (= keys "l") ang2 ang1 ) (if (= keys "l") ang1 ang2 ) r)))
      (vla-delete obj)      
      (entmakex (list '(0 . "LWPOLYLINE")
                      '(100 . "AcDbEntity")
                      '(100 . "AcDbPolyline")
                      (cons 90 3)
                      (cons 10 p1)
                      (cons 42 (if (= keys "l") bulge (* -1.0 bulge) ))
                      (cons 10 p2)
                      (cons 40 w)
                      (cons 41 0)                     
                      (cons 10 p3)))
      )
    )
(princ)
)

sibelle_hu 发表于 2014-8-8 20:46:40

edata 发表于 2014-8-8 20:35 static/image/common/back.gif


大师，非常好！谢谢了！

ysq101 发表于 2014-8-8 22:04:09

本帖最后由 ysq101 于 2014-8-9 12:17 编辑

Z版主直接给了鱼
我来点思路，楼主想学LIPS还是自己动手来吧
说说我的思路：
2段多线段   修改剪头部分的线宽即可
自己研究一下吧

其它箭头可以做成动态的好点吧
页: [1] 2
查看完整版本: 请问用lisp能不能画这样的图？