求一个这样的逃孔lsp程序

Smile cop · 发表于 2013-4-29 16:37:41

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 rxing 于 2013-12-8 12:32 编辑

这样的逃孔lsp：

Lispboy · 发表于 2013-4-29 17:13:15

这程序好像EACHY大师做过，搜索下论坛看看。

Smile cop · 发表于 2013-4-30 14:15:01

Lispboy 发表于 2013-4-29 17:13

登录/注册后可看大图

这程序好像EACHY大师做过，搜索下论坛看看。

这程序好像EACHY大师做过,没有收到啊

Smile cop · 发表于 2013-4-30 18:04:10

附件此程序还不完善，谁能够帮忙完善下，谢谢！
[pcode=lisp,true];|
  求拾取框的高度
|;
(defun $XDLSP_Drawing_getPickboxHeight ()
  (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
   (getvar "viewsize")
  )
)
;;
(defun $XDLSP_SelectBypt (p filter / h)
  (setq h ($XDLSP_Drawing_getPickboxHeight))
  (ssget "C"
      (mapcar '+ p (list h h 0.))
      (mapcar '- p (list h h 0.))
      filter
  )
)
(vl-load-com)
(defun c:tt (/       e obj  p       r sp ep       el p1       p2 p0
         d       pam  ss e1       sp1  ep1  p3       p4 r1       d1 d2
         p20  p10  p21  pcen pmid p00  d0       p11
         )
  (setvar "dimzin" 0)
  (setq       r  10.
      kw "1"
      d0 5.
  )

  (if (not
      (setq r (getdist (strcat "\n半径<" (rtos r 2 2) ">: ")))
   )
(setq r 10.)
  )
  (initget 128 "1 2")
  (if (not
      (setq
      kw (getkword (strcat "\n[1 - 标准/2 - 角]<" kw ">: "))
      )
   )
(setq kw "1")
  )
  (and
(= kw "1")
(if       (not
      (setq d0 (getdist (strcat "\n逃孔量<" (rtos d0 2 2) ">: ")))
      )
   (setq d0 5.)
)
  )
  (while
(and (setq e (entsel "\n拾取角线<退出>: "))
      (setq obj (vlax-ename->vla-object (car e))
            el  (entget (car e))
            p (cadr e)
            sp  (vlax-curve-getstartpoint obj)
            ep  (vlax-curve-getendpoint obj)
            d (vlax-curve-getendparam obj)
            p0  (vlax-curve-getclosestpointto obj p)
            pam (vlax-curve-getparamatpoint obj p0)
      )
      (if (< pam (* d 0.5))
         (setq p1  sp
               p11 ep
         )
         (setq p1  ep
               p11 sp
         )
      )
      (if (<= (sslength (setq
                           ss       ($XDLSP_SelectBypt
                              p1
                              (list (assoc 0 el) (assoc 8 el))
                              )
                        )
               )
               2
         ) ;_仅有两个线
         (if (equal (setq e1 (ssname ss 0)) (car e))
         (setq e1 (ssname ss 1))
         e1
         )
      )
)
   (setq sp1 (vlax-curve-getstartpoint e1)
         ep1 (vlax-curve-getendpoint e1)
   )
   (if (< (distance p1 sp1) (distance p1 ep1))
   (setq p2 ep1)
   (setq p2 sp1)
   )
   (if (= kw "2")
   (progn
      (vlax-put obj 'Startpoint (polar p1 (angle p1 p11) (* r 2)))
      (vlax-put obj 'Endpoint p11)
      (setq p3 (polar p1 (angle p1 p0) r)
            p4 (polar p3 (angle p2 p1) r)
      )
      (vl-cmdf ".point" p3)
      (vl-cmdf ".point" p4)
      (vl-cmdf ".arc"
               "_None"
               p1
               "_none"
               p4
               "_None"
               (polar p1 (angle p1 p0) (* 2 r))
      )
   )
   (progn
      (setq p20  (polar p1 (angle p1 p2) 1.)
            p00  (polar p1 (angle p1 p0) 1.)
            pmid (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p20 p00))
            p4 (polar p1 (angle pmid p1) d0)
            pcen (polar p4 (angle p4 p1) r)
            d1 (distance (vlax-curve-getclosestpointto (car e) pcen)
                           pcen
                  )
            p10  (polar p1
                        (angle p1 p0)
                        (setq d2 (+ d1 (sqrt (- (* r r) (* d1 d1)))))
                  )
            p21  (polar p1 (angle p1 p2) d2)
      )
      (vlax-put obj 'Startpoint p10)
      (vlax-put obj 'Endpoint p11)
      (vlax-put (setq obj (vlax-ename->vla-object e1)) 'Startpoint p21)
      (vlax-put obj 'Endpoint p2)
      (vl-cmdf ".arc" "_none" p10 "_none" p4 "_none" p21)
   )
   )
  )
  (princ)
)[/pcode]
1.此程序没有相应的能够恢复成逃角之前的原图，也就是取消逃角，要能够按用户指定的地方取消逃角。
2.此程序只能对直线的有效，而对已多段线、已经串接（join）好一整体的线段是直接退出，做不出逃角。
3.此程序只能单独的选择做出逃角，而不能对于多段线（串接好一整体的线段）一次做出多个逃角。可不可以实现连逃角。
4.最后逃角后的图形是单独的线，需要的是串接的线（也就是使用pedit结合后的线）

Smile cop · 发表于 2013-5-1 11:22:20

只要把上面的几点改善下就好了，谢谢！

Smile cop · 发表于 2013-5-1 11:59:43

不知道大家有什么看不懂得地方没有，期待大家回复，谢谢！！！

Smile cop · 发表于 2013-5-3 20:01:42

期待大家回复,再顶下

Lispboy · 发表于 2013-5-3 20:12:19

本帖最后由 Lispboy 于 2013-5-3 20:13 编辑

rxing 发表于 2013-4-30 18:04

登录/注册后可看大图

附件此程序还不完善，谁能够帮忙完善下，谢谢！
;|
求拾取框的高度

为什么要想程序一次性都做好呢？四边形总共就四个角，点一个角就做一个，不也挺好的吗？四个一起做，程序要考虑的就多了。上面这个程序就是EACHY大师写的那个吧，看着好眼熟。

Smile cop · 发表于 2013-5-4 11:48:58

Lispboy 发表于 2013-5-3 20:12

登录/注册后可看大图

为什么要想程序一次性都做好呢？四边形总共就四个角，点一个角就做一个，不也挺好的吗？四个一起做，程序 ...

楼主高见！上面这个程序是EACHY大师写的，但是由于最近EACHY大师很忙，没能够完成后半部分，真的遗憾，也期盼高手们能够完成他的续集，期待高手们帮忙。如果一次性能够把多义线做好那是最好的了，因为我看到有连续倒角的命令在cad中，能够一次把pline线做出倒角！

xyp1964 · 发表于 2013-5-4 14:08:56

本帖最后由 xyp1964 于 2013-5-4 14:12 编辑

fktk(方块逃孔)01.gif

Gdlprfcu · 发表于 2013-5-5 16:23:06

我也正准备做一个，感觉应该不难.

Smile cop · 发表于 2013-5-7 21:01:32

哪位好心人能否分享下这个程序，小生谢谢了！！！

牢固 · 发表于 2013-5-8 15:56:45

本帖最后由牢固于 2014-1-6 19:23 编辑

rxing 发表于 2013-5-7 21:01

登录/注册后可看大图

哪位好心人能否分享下这个程序，小生谢谢了！！！

如果无法播放，请点击此处在新窗口打开

逃孔绘制源码:
[sell=10]
[pcode=lisp,true];;逃孔绘制 By Gu_xl 2013.05.08;;更新 2014.01.06 不封闭多段线可以逃孔，已经逃孔部位的不再逃孔
(defun c:taokong (/ TK1 TK2 KD A R SS N E)
  ;;标准逃孔计算
  (defun tk1 (E A    R    /    N    EL    I    P1    P2
            P3    CLOCKWISEP MIDANG CP    MRP STP ENP
            MP    BULGE  ARCDATA    OBJ A1 A2 k
            )
(setq obj (vlax-ename->vla-object e))
(if (vlax-curve-isClosed obj)
   (progn
      (setq i 0)
      (setq n (fix (vlax-curve-getEndParam obj)))
      )
   (progn
      (setq i 0)
      (setq n (1- (fix (vlax-curve-getEndParam obj)) ))
      )
   )

(repeat n
   (setq p1 (vlax-curve-getPointAtParam e i)
         p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
         p3 (vlax-curve-getPointAtParam e (1+ i))
         )
   (if (and
         (vlax-curve-isClosed obj)
         (equal i (vlax-curve-getEndParam obj) 1e-6)
         )
      (setq k 0)
      (setq k i)
      )
   (if (and
         (equal 0 (vla-GetBulge obj (1- i)) 1e-6)
         (equal 0 (vla-GetBulge obj k) 1e-6)
         )
      (progn
   (if (null p3) (setq p3 (vlax-curve-getPointAtParam e 1)))
   (setq a1 (angle p2 p1)
         a2 (angle p2 p3)
         )
   (setq clockwisep
         (<
            (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
            )
         )
   (if (< a1 a2) (setq a1 (+ a1 pi pi)))
   (setq midang (* 0.5 (+ a1 a2)))
   (if clockwisep
      (setq cp (polar p2 midang (- a r))
            mrp (polar p2 midang a)
            )
      (setq cp (polar p2 midang (- r a))
            mrp (polar p2 midang (- a))
            )
      )
   (setq stp (car (vl-remove-if-not
                     '(lambda (x)
                        (equal (+ (distance p1 x) (distance p2 x))
                              (distance p1 p2)
                              1e-6
                              )
                        )
                     (IntersLineCircle p2 p1 cp r)
                     )
                  )
         ) ;_ 圆弧起点
   (setq enp (car (vl-remove-if-not
                     '(lambda (x)
                        (equal (+ (distance p3 x) (distance p2 x))
                              (distance p3 p2)
                              1e-6
                              )
                        )
                     (IntersLineCircle p2 p3 cp r)
                     )
                  )
         ) ;_ 圆弧终点
   (setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
   (setq bulge (/ (distance mrp mp) (distance mp stp))) ;_ 弓弦比
   (if clockwisep (setq bulge (- bulge)))
   (setq arcdata (cons (list stp enp bulge) arcdata))
   )
      )
   )
(setq  arcdata (reverse arcdata))
(foreach data arcdata
   (setq stp (car data)
         enp (cadr data)
         bulge (caddr data)
         )
   (setq n (fix (vlax-curve-getParamAtPoint
                  obj
                  (vlax-curve-getclosestpointto obj enp)
                  )
               )
         )
   (vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
   (if (vlax-curve-getPointAtParam obj (1+ n))
   (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
      (vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
      )
   (vla-SetBulge obj n bulge)
   )
)
  ;;顺时针。逆时针逃孔计算
  (defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
            N k)
(setq obj (vlax-ename->vla-object e))
(setq polyClock (not (gxl-clock e)))
(setq i 0)
(if (vlax-curve-isClosed obj)
   (progn
      (setq i 0)
      (setq n (fix (vlax-curve-getEndParam obj)))
      )
   (progn
      (setq i 0)
      (setq n (1- (fix (vlax-curve-getEndParam obj))))
      )
   )
(repeat n
   (setq p1 (vlax-curve-getPointAtParam obj i)
         p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
         p3 (vlax-curve-getPointAtParam obj (1+ i))
         )
   (if (and
         (vlax-curve-isClosed obj)
         (equal i (vlax-curve-getEndParam obj) 1e-6)
         )
      (setq k 0)
      (setq k i)
      )
   (if (and
         (equal 0 (vla-GetBulge obj (1- i)) 1e-6)
         (equal 0 (vla-GetBulge obj k) 1e-6)
         )
      (progn
   (if (null p3) (setq p3 (vlax-curve-getPointAtParam obj 1)))
   (cond
      (polyClock ;_ 曲线顺时针
      (cond
         (clock ;_ 顺时针逃孔
         ;;(加点弓弦比 T在加点处修改弓弦比，nil在上处修改弓弦比)
         (setq arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil) arcdata))
         )
         (t ;_ 逆时针逃孔
         (setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t) arcdata))
         )
         )
      )
      (t ;_ 曲线逆时针
      (cond
         (clock ;_ 顺时针逃孔
         (setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t) arcdata))
         )
         (t ;_ 逆时针逃孔
         (setq arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil) arcdata))
         )
         )
      )
      )
   )
)
   )
   (setq  arcdata (reverse arcdata))
(foreach data arcdata
   (setq pt (car data)
         bulge (cadr data)
         flag (caddr data)
         )
   (setq n (fix (vlax-curve-getParamAtPoint
                  obj
                  (vlax-curve-getclosestpointto obj pt)
                  )
               )
         )
   (if (vlax-curve-getPointAtParam obj (1+ n))
      (progn
      (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
      (if flag
         (vla-SetBulge obj (1+ n) bulge)
         (vla-SetBulge obj n bulge)
         )
      )
      (progn
      (vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
      (if flag
         (vla-SetBulge obj 1 bulge)
         (vla-SetBulge obj 0 bulge)
         )
      )
      )
   )
   )
  (initget "1 2 3")
  (if (null
      (setq kd (getkword "\n[标准(1)/顺时针(2)/逆时针(3)]<1>"))
      )
(setq kd "1")
)
  (cond
((= "1" kd)
   (if (null (setq a (getreal "\n逃孔量<5.0>:")))
   (setq a 5.0)
   )
   (if (null (setq r (getreal "\n逃孔半径<10.0>:")))
   (setq r 10.0)
   )
   (while (setq ss (ssget '((0 . "lwpolyline"))))
   (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (tk1 e a r) ;_ 修剪逃孔
      )
   )
   )
(t
   (if (null (setq r (getreal "\n逃孔半径<10.0>:")))
   (setq r 10.0)
   )
   (while (setq ss (ssget '((0 . "*polyline"))))
   (repeat (setq n (sslength ss))
      (setq e (ssname ss (setq n (1- n))))
      (tk2 e  r (= "2" kd)) ;_ 修剪逃孔
      )
   )
   )
)
  (princ)
  )
;;*******************以下是一些用到的自定义函数****************************
;; Line-Circle Intersection - Lee Mac
;;直线与园交点
(defun IntersLineCircle ( p q c r / a d n s )
  (setq n (mapcar '- q p)
      p (trans p 0 n)
      c (trans c 0 n)
      a (list (car p) (cadr p) (caddr c))
  )
  (cond
( (equal r (setq d (distance c a)))
   (list (trans a n 0))
)
( (< d r)
   (setq s (sqrt (- (* r r) (* d d))))
   (list
      (trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
      (trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
   )
)
  )
)
;;转换一个点到一个二维ActiveX点
(defun gxl-Ax:2DPoint (pt)
  (vlax-make-variant
(vlax-safearray-fill
   (vlax-make-safearray vlax-vbdouble '(0 . 1))
   (list (car pt) (cadr pt))
)
  )
)
;;判断点表或非自交封闭曲线的是否顺时针
(defun gxl-clock  (PLIST / LW MINP MAXP LST)
  (cond       ((= 'LIST (type plist))
      (not
         (minusp
            (apply '+
                  (mapcar
                     (function
                     (lambda (a b)
                        (- (* (car b) (cadr a)) (* (car a) (cadr b)))
                     )
                     )
                     plist
                     (cons (last plist) plist)
                  )
            )
         )
      )
      )
      (t
      (if (= 'ename (type plist))
         (setq lw (vlax-ename->vla-object plist))
         (if (= 'VLA-OBJECT (type plist))
         (setq lw plist)
         )
         )
      (vla-GetBoundingBox lw 'MinP 'MaxP)
      (setq
         minp       (vlax-safearray->list minp)
         MaxP       (vlax-safearray->list MaxP)
         lst       (mapcar
               (function
                  (lambda (x)
                  (vlax-curve-getParamAtPoint
                     lw
                     (vlax-curve-getClosestPointTo lw x)
                     )
                  )
                  )
               (list       minp
                     (list (car MaxP) (cadr minp))
                     MaxP
                     (list (car minp) (cadr MaxP))
                     )
               )
         )
      (if (or
            (<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
            (<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
            (<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
            (<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
            )
         t
         )
      )
      )

  )
;;*******************以上是一些用到的自定义函数****************************

[/pcode]
[/sell]

zxq0220 · 发表于 2013-5-9 08:12:25

几大版主都出手了，:lol偶就看看热闹。

Smile cop · 发表于 2013-5-10 23:31:54

使用上面的程序为什么会出现错误: no function definition: INTERSLINECIRCLE

账号		自动登录	找回密码
密码			立即注册

[编程申请] 求一个这样的逃孔lsp程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

评分