明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 3301|回复: 23

[源码] 等分矩形

[复制链接]
发表于 2021-9-4 16:45:21 | 显示全部楼层 |阅读模式
  1. (defun mkrec (pt n a h a1 h1 k1 k2)
  2.   (if k1
  3.     (if  k2
  4.       (repeat n
  5.   (entmake
  6.     (list
  7.       '(0 . "LWPOLYLINE")
  8.       '(100 . "AcDbEntity")
  9.       '(100 . "AcDbPolyline")
  10.       '(90 . 4)
  11.       '(70 . 1)
  12.       '(62 . 3)
  13.       (cons 10
  14.       (setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
  15.       )
  16.       (cons 10 (setq pt (mapcar '+ (list 0 h) pt)))
  17.       (cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
  18.       (cons 10 (setq pt (mapcar '+ (list 0 (- h)) pt)))
  19.     )
  20.   )
  21.   (setq pt (mapcar '+ (list (* 0.5 dis) (* -0.5 dis)) pt))
  22.       )
  23.       (repeat n
  24.   (entmake
  25.     (list
  26.       '(0 . "LWPOLYLINE")
  27.       '(100 . "AcDbEntity")
  28.       '(100 . "AcDbPolyline")
  29.       '(90 . 4)
  30.       '(70 . 1)
  31.       '(62 . 3)
  32.       (cons 10
  33.       (setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
  34.       )
  35.       (cons 10 (setq pt (mapcar '+ (list a 0) pt)))
  36.       (cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
  37.       (cons 10 (setq pt (mapcar '+ (list (- a) 0) pt)))
  38.     )
  39.   )
  40.   (setq pt (mapcar '+ (list (* -0.5 dis) (* 0.5 dis)) pt))
  41.       )
  42.     )
  43.     (if  k2
  44.       (repeat n
  45.   (grvecs
  46.     (list  1
  47.     (setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
  48.     (setq pt (mapcar '+ (list 0 h) pt))
  49.     1
  50.     pt
  51.     (setq pt (mapcar '+ (list a1 0) pt))
  52.     1
  53.     pt
  54.     (setq pt (mapcar '+ (list 0 (- h)) pt))
  55.     1
  56.     pt
  57.     (mapcar '+ (list (- a1) 0) pt)
  58.     )
  59.   )
  60.   (setq pt (mapcar '+ (list (* 0.5 dis) (* -0.5 dis)) pt))
  61.       )
  62.       (repeat n
  63.   (grvecs
  64.     (list  1
  65.     (setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
  66.     (setq pt (mapcar '+ (list a 0) pt))
  67.     1
  68.     pt
  69.     (setq pt (mapcar '+ (list 0 h1) pt))
  70.     1
  71.     pt
  72.     (setq pt (mapcar '+ (list (- a) 0) pt))
  73.     1
  74.     pt
  75.     (mapcar '+ (list 0 (- h1)) pt)
  76.     )
  77.   )
  78.   (setq pt (mapcar '+ (list (* -0.5 dis) (* 0.5 dis)) pt))
  79.       )
  80.     )
  81.   )
  82. )
  83. (defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
  84.   (vl-load-com)
  85.   (setvar "cmdecho" 0)
  86.   (or (setq dis (getdist "\n请输入格子间距<10>:"))
  87.       (setq dis 10)
  88.   )
  89.   (or (setq n (getint "\n请输入要等分的个数<3>:"))
  90.       (setq n 3)
  91.   )
  92.   (setq pt (getpoint "\n请选择矩形框你一点:"))
  93.   (command "boundary" pt "")
  94.   (setq ent (entlast))
  95.   (vla-GetBoundingBox
  96.     (vlax-ename->vla-object ent)
  97.     'minpt
  98.     'maxpt
  99.   )
  100.   (setq  minpt (vlax-safearray->list minpt)
  101.   maxpt (vlax-safearray->list maxpt)
  102.   )
  103.   (entdel ent)
  104.   (setq  x1 (car minpt)
  105.   x2 (car maxpt)
  106.   y1 (cadr minpt)
  107.   y2 (cadr maxpt)
  108.   a  (- x2 x1)
  109.   h  (- y2 y1)
  110.   a1 (/ (- a (* dis n)) n)
  111.   h1 (/ (- h (* dis n)) n)
  112.   )
  113.   (setq loop t)
  114.   (while loop
  115.     (setq code (setq code (grread T 8)))
  116.     (cond ((= (car code) 5)
  117.      (setq pt0 (cadr code))
  118.      (redraw)
  119.      (grdraw pt pt0 1)
  120.      (mkrec minpt
  121.       n
  122.       (- a dis)
  123.       (- h dis)
  124.       a1
  125.       h1
  126.       nil
  127.       (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  128.           (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  129.       )
  130.      )
  131.     )
  132.     ((= (car code) 3)
  133.      (setq pt0 (cadr code))
  134.      (redraw)
  135.      (grdraw pt pt0 1)
  136.      (mkrec minpt
  137.       n
  138.       (- a dis)
  139.       (- h dis)
  140.       a1
  141.       h1
  142.       nil
  143.       (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  144.           (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  145.       )
  146.      )
  147.      (setq loop nil)
  148.     )
  149.     (t nil)
  150.     )
  151.   )
  152.   (redraw)
  153.   (mkrec minpt
  154.    n
  155.    (- a dis)
  156.    (- h dis)
  157.    a1
  158.    h1
  159.    t
  160.    (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  161.        (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  162.    )
  163.   )
  164.   (princ)
  165. )
  166.      


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 3明经币 +3 收起 理由
xiangganglv + 1 赞一个!
panliang9 + 1 赞一个!
lee50310 + 1 赞一个!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2021-9-5 01:47:24 | 显示全部楼层
本帖最后由 kkq0305 于 2021-9-5 01:49 编辑
  1. (defun mkrec (pt n a h a1 h1 k1 k2)
  2.   (if k1
  3.     (if        k2
  4.       (repeat n
  5.         (entmake
  6.           (list
  7.             '(0 . "LWPOLYLINE")
  8.             '(100 . "AcDbEntity")
  9.             '(100 . "AcDbPolyline")
  10.             '(90 . 4)
  11.             '(70 . 1)
  12.             '(62 . 3)
  13.             (cons 10
  14.                   (setq pt (mapcar '+ (list 0 0) pt))
  15.             )
  16.             (cons 10 (setq pt (mapcar '+ (list 0 h) pt)))
  17.             (cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
  18.             (cons 10 (setq pt (mapcar '+ (list 0 (- h)) pt)))
  19.           )
  20.         )
  21.         (setq pt (mapcar '+ (list dis 0) pt))
  22.       )
  23.       (repeat n
  24.         (entmake
  25.           (list
  26.             '(0 . "LWPOLYLINE")
  27.             '(100 . "AcDbEntity")
  28.             '(100 . "AcDbPolyline")
  29.             '(90 . 4)
  30.             '(70 . 1)
  31.             '(62 . 3)
  32.             (cons 10
  33.                   (setq pt (mapcar '+ (list 0 0) pt))
  34.             )
  35.             (cons 10 (setq pt (mapcar '+ (list a 0) pt)))
  36.             (cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
  37.             (cons 10 (setq pt (mapcar '+ (list (- a) 0) pt)))
  38.           )
  39.         )
  40.         (setq pt (mapcar '+ (list 0 dis) pt))
  41.       )
  42.     )
  43.     (if        k2
  44.       (repeat n
  45.         (grvecs
  46.           (list        1
  47.                 (setq pt (mapcar '+ (list 0 0) pt))
  48.                 (setq pt (mapcar '+ (list 0 h) pt))
  49.                 1
  50.                 pt
  51.                 (setq pt (mapcar '+ (list a1 0) pt))
  52.                 1
  53.                 pt
  54.                 (setq pt (mapcar '+ (list 0 (- h)) pt))
  55.                 1
  56.                 pt
  57.                 (mapcar '+ (list (- a1) 0) pt)
  58.           )
  59.         )
  60.         (setq pt (mapcar '+ (list dis 0) pt))
  61.       )
  62.       (repeat n
  63.         (grvecs
  64.           (list        1
  65.                 (setq pt (mapcar '+ (list 0 0) pt))
  66.                 (setq pt (mapcar '+ (list a 0) pt))
  67.                 1
  68.                 pt
  69.                 (setq pt (mapcar '+ (list 0 h1) pt))
  70.                 1
  71.                 pt
  72.                 (setq pt (mapcar '+ (list (- a) 0) pt))
  73.                 1
  74.                 pt
  75.                 (mapcar '+ (list 0 (- h1)) pt)
  76.           )
  77.         )
  78.         (setq pt (mapcar '+ (list 0 dis) pt))
  79.       )
  80.     )
  81.   )
  82. )
  83. (defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
  84.   (vl-load-com)
  85.   (setvar "cmdecho" 0)
  86.   (or (setq dis (getdist "\n请输入格子间距<10>:"))
  87.       (setq dis 10)
  88.   )
  89.   (or (setq n (getint "\n请输入要等分的个数<3>:"))
  90.       (setq n 3)
  91.   )
  92.   (setq pt (getpoint "\n请选择矩形框你一点:"))
  93.   (command "boundary" pt "")
  94.   (setq ent (entlast))
  95.   (vla-GetBoundingBox
  96.     (vlax-ename->vla-object ent)
  97.     'minpt
  98.     'maxpt
  99.   )
  100.   (setq        minpt (vlax-safearray->list minpt)
  101.         maxpt (vlax-safearray->list maxpt)
  102.   )
  103.   (entdel ent)
  104.   (setq        x1 (car minpt)
  105.         x2 (car maxpt)
  106.         y1 (cadr minpt)
  107.         y2 (cadr maxpt)
  108.         a  (- x2 x1)
  109.         h  (- y2 y1)
  110.         a1 (/ (- a (* dis (1- n))) n)
  111.         h1 (/ (- h (* dis (1- n))) n)
  112.   )
  113.   (setq loop t)
  114.   (while loop
  115.     (setq code (setq code (grread T 8)))
  116.     (cond ((= (car code) 5)
  117.            (setq pt0 (cadr code))
  118.            (redraw)
  119.            (grdraw pt pt0 1)
  120.            (mkrec minpt
  121.                   n
  122.                   a
  123.                   h
  124.                   a1
  125.                   h1
  126.                   nil
  127.                   (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  128.                       (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  129.                   )
  130.            )
  131.           )
  132.           ((= (car code) 3)
  133.            (setq pt0 (cadr code))
  134.            (redraw)
  135.            (grdraw pt pt0 1)
  136.            (mkrec minpt
  137.                   n
  138.                   a
  139.                   h
  140.                   a1
  141.                   h1
  142.                   nil
  143.                   (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  144.                       (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  145.                   )
  146.            )
  147.            (setq loop nil)
  148.           )
  149.           (t nil)
  150.     )
  151.   )
  152.   (redraw)
  153.   (mkrec minpt
  154.          n
  155.          a
  156.          h
  157.          a1
  158.          h1
  159.          t
  160.          (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
  161.              (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
  162.          )
  163.   )
  164.   (princ)
  165. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
回复 支持 0 反对 1

使用道具 举报

发表于 2021-9-5 22:06:58 | 显示全部楼层

烦请大师帮忙改下,我改的出错


(defun getcorn (/ corn-get corn-name corn-lst corn-ss corn-xh corn-bd)
  (princ "\n点取区域")
  (setq corn-xh t)
  (while corn-xh
    (setq corn-get (grread 1 7 0))        ;把当前的转入设备的值赋给变量
    (cond      
      ((= 5 (car corn-get))                ;mousemove
       (setq corn-lst nil)
       (setq corn-name (4-line corn-get fp))
                                        ;画出4条直线,并返回每条线的起点终点
       (mapcar
         '(lambda (x)
            (setq
              corn-ss (ssget
                        "c"                ;选择每条直线相交的图元,块除外
                        (cadr x)
                        (caddr x)
                        '((0 . "LWPOLYLINE,LINE"))
                      )
            )
            (mapcar '(lambda (y) (ssdel (car y) corn-ss)) corn-name)
                                        ;从选择集去除辅助线
            (redraw)
            (if        (> (sslength corn-ss) 0)             
              (setq
                corn-lst (cons (All-inters (car x) corn-ss) corn-lst)
              )
                                        ;所有交点的表
            )
          )
         corn-name
       )
       (setq corn-lst (reverse corn-lst))
       (mapcar '(lambda (x) (entdel (car x))) corn-name) ;删除4条直线
       (setq corn-bd (Lately-pt corn-lst))
       (redraw)
       (display corn-bd)
      )
      ((= 3 (car corn-get))                ;变量为3开头时为点击左键
       (setq  corn-xh nil)
      )
      ((= 11 (car corn-get))                ;rightdown
       (setq corn-bd nil corn-xh nil)
      )
    )
  )

  (redraw)
  corn-bd
)
;;说明:判断表是不是4个元素
(defun Lately-pt (lst / min-x max-x min-y max-y)
  (if (= (length lst) 4)
    (progn
      (setq max-y (car (vl-sort (mapcar 'cadr (nth 0 lst)) '<)))
      (setq min-y (car (vl-sort (mapcar 'cadr (nth 1 lst)) '>)))
      (setq min-x (car (vl-sort (mapcar 'car (nth 2 lst)) '>)))
      (setq max-x (car (vl-sort (mapcar 'car (nth 3 lst)) '<)))
      (list (list min-x min-y 0.0) (list max-x max-y 0.0))
    )
  )
)
;;说明:以鼠标为起点绘制4条直线
;;参数:get:当前鼠标坐标
;;参数:lst:当前屏幕坐标
;;返回:lst 4个图元名+起点+终点  上下左右
(defun 4-line (get          lst             /                line_name_s
               line_name_x             line_name_y           line_name_z
               pt1          pt2             pt3        pt4           pt5
              )
  (setq pt5 (cadr get))

                                        ;纵向直线上
  (setq        line_name_s
         (entmakex
           (list
             '(0 . "LINE")
             (cons 10 (trans pt5 1 0))
             (cons
               11
               (trans (setq pt1 (list (caadr get) (cadadr (lst))))
                      1
                      0
               )
             )
           )
         )
  )
                                        ;纵向直线下
  (setq        line_name_x
         (entmakex
           (list
             '(0 . "LINE")
             (cons 10 (trans pt5 1 0))
             (cons
               11
               (trans (setq pt2 (list (caadr get) (cadar (lst))))
                      1
                      0
               )
             )
           )
         )
  )
                                        ;横向直线左
  (setq        line_name_z
         (entmakex
           (list
             '(0 . "LINE")
             (cons 10 (trans pt5 1 0))
             (cons
               11
               (trans (setq pt3 (list (caar (lst)) (cadadr get)))
                      1
                      0
               )
             )
           )
         )
  )
                                        ;横向直线右
  (setq        line_name_y
         (entmakex
           (list
             '(0 . "LINE")
             (cons 10 (trans pt5 1 0))
             (cons
               11
               (trans (setq pt4 (list (caadr (lst)) (cadadr get)))
                      1
                      0
               )
             )
           )
         )
  )
  (list
    (list line_name_s pt5 pt1)
    (list line_name_x pt5 pt2)
    (list line_name_z pt5 pt3)
    (list line_name_y pt5 pt4)
  )
)
                                        ;屏幕两对角坐标
(defun fp (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
  (setq        c03 (getvar "viewctr")
        c03 (trans c03 1 2)
        c08 (getvar "viewsize")
        c04 (getvar "screensize")
        c07 (car c04)
        c06 (cadr c04)
        c09 (/ (* c08 c07) c06)
        c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
        c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
        c01 (trans c01 2 1)
        c02 (trans c02 2 1)
  )
  (list c01 c02)
)

(defun All-inters
       (name ss / All-inters-pt All-inters-lst All-inters-xh)
  (setq All-inters-xh 0)
  (repeat (sslength ss)
    (if        (setq All-inters-pt
               (tt:TwoEntsInters
                 name
                 (ssname ss All-inters-xh)
                 0
               )
        )
      (setq All-inters-lst (append All-inters-pt All-inters-lst))
    )
    (setq All-inters-xh (1+ All-inters-xh))
  )
  All-inters-lst
)
(defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
  (vl-load-com)
  (setvar "cmdecho" 0)
  (or (setq dis (getdist "\n请输入格子间距<18>:"))
      (setq dis 18)
  )
  (or (setq n (getint "\n请输入要等分的个数<3>:"))
      (setq n 3)
  )
  (setq pt (getpoint "\n请选择矩形框你一点:"))
  (command "boundary" pt "")
  (setq ent (entlast))
  (vla-GetBoundingBox
    (vlax-ename->vla-object ent)
   ; 'minpt
   ; 'maxpt
  )
  ;(setq        minpt (vlax-safearray->list minpt)
   ;     maxpt (vlax-safearray->list maxpt)
  )
  (entdel ent)
  (setq        x1 (car minpt)
       ; x2 (car maxpt)
        ;y1 (cadr minpt)
        ;y2 (cadr maxpt)
        a  (- x2 x1)
        h  (- y2 y1)
        a1 (/ (- a (* dis (1- n))) n)
        h1 (/ (- h (* dis (1- n))) n)
  )
  (setq loop t)
  (while loop
    (setq code (setq code (grread T 8)))
    (cond ((= (car code) 5)
           (setq pt0 (cadr code))
           (redraw)
           (grdraw pt pt0 1)
           ;(mkrec minpt
                  n
                  a
                  h
                  a1
                  h1
                  nil
                  (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
                      (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
                  )
           )
          )
          ((= (car code) 3)
           (setq pt0 (cadr code))
           (redraw)
           (grdraw pt pt0 1)
          ; (mkrec minpt
                  n
                  a
                  h
                  a1
                  h1
                  nil
                  (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
                      (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
                  )
           )
           (setq loop nil)
          )
          (t nil)
    )
  )
  (redraw)
  ;(mkrec minpt
         n
         a
         h
         a1
         h1
         t
         (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
             (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
         )
  )
  (princ)
)
发表于 2021-9-4 17:15:53 | 显示全部楼层
板凳端上,,  谢谢楼主分享
发表于 2021-9-4 18:07:40 来自手机 | 显示全部楼层
漂亮的很哦

点评

q:1016769094  发表于 2021-9-5 13:30
发表于 2021-9-4 20:11:07 | 显示全部楼层
膜拜大佬,感谢分享,收下学习了
发表于 2021-9-5 19:51:47 | 显示全部楼层
谢谢楼主的分享。。。。
发表于 2021-9-5 20:52:07 | 显示全部楼层
本帖最后由 qianyi0710 于 2021-9-5 21:00 编辑

非常感谢,下载下来学习下,(格子间距)   要是独立直线就好。要是直线就完美了。
 楼主| 发表于 2021-9-6 02:45:49 | 显示全部楼层
(defun mkrec (pt n a h a1 h1 k1 k2)
  (if k1
    (if        k2
      (repeat (1- n)
        (entmake
          (list
            '(0 . "LINE")
            (cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
            (cons 11 (setq pt (mapcar '+ (list 0 h) pt)))
                                        )
                                )
                          (entmake
          (list
            '(0 . "LINE")       
            (cons 10 (setq pt (mapcar '+ (list dis 0) pt)))
            (cons 11 (setq pt (mapcar '+ (list 0 (- h)) pt)))
          )
        )
      )
      (repeat (1- n)
        (entmake
          (list
            '(0 . "LINE")
            (cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
            (cons 11 (setq pt (mapcar '+ (list a 0) pt)))
                                        )
                                )
                          (entmake
          (list
            '(0 . "LINE")       
            (cons 10 (setq pt (mapcar '+ (list 0 dis) pt)))
            (cons 11 (setq pt (mapcar '+ (list (- a) 0) pt)))
          )
        )
      )
    )
    (if        k2
      (repeat n
        (grvecs
          (list        1
                (setq pt (mapcar '+ (list 0 0) pt))
                (setq pt (mapcar '+ (list 0 h) pt))
                1
                pt
                (setq pt (mapcar '+ (list a1 0) pt))
                1
                pt
                (setq pt (mapcar '+ (list 0 (- h)) pt))
                1
                pt
                (mapcar '+ (list (- a1) 0) pt)
          )
        )
        (setq pt (mapcar '+ (list dis 0) pt))
      )
      (repeat n
        (grvecs
          (list        1
                (setq pt (mapcar '+ (list 0 0) pt))
                (setq pt (mapcar '+ (list a 0) pt))
                1
                pt
                (setq pt (mapcar '+ (list 0 h1) pt))
                1
                pt
                (setq pt (mapcar '+ (list (- a) 0) pt))
                1
                pt
                (mapcar '+ (list 0 (- h1)) pt)
          )
        )
        (setq pt (mapcar '+ (list 0 dis) pt))
      )
    )
  )
)
(defun c:CB (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
  (vl-load-com)
  (setvar "cmdecho" 0)
  (or (setq dis (getdist "\n请输入层板厚度<18>:"))
      (setq dis 18)
  )
  (or (setq n (getint "\n请输入要等分的数<3>:"))
      (setq n 3)
  )
  (setq pt (getpoint "\n请选择矩形框内一点:"))
  (command "-boundary" "a" "i" "n" "" "o" "r" "" pt "")
  (setq ent (entlast))
  (vla-GetBoundingBox
    (vlax-ename->vla-object ent)
    'minpt
    'maxpt
  )
  (setq        minpt (vlax-safearray->list minpt)
        maxpt (vlax-safearray->list maxpt)
  )
  (entdel ent)
  (setq        x1 (car minpt)
        x2 (car maxpt)
        y1 (cadr minpt)
        y2 (cadr maxpt)
        a  (- x2 x1)
        h  (- y2 y1)
        a1 (/ (- a (* dis (1- n))) n)
        h1 (/ (- h (* dis (1- n))) n)
  )
  (setq loop t)
  (while loop
    (setq code (setq code (grread T 8)))
    (cond ((= (car code) 5)
           (setq pt0 (cadr code))
           (redraw)
           (grdraw pt pt0 1)
           (mkrec minpt
                  n
                  a
                  h
                  a1
                  h1
                  nil
                  (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
                      (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
                  )
           )
          )
          ((= (car code) 3)
           (setq pt0 (cadr code))
           (redraw)
           (grdraw pt pt0 1)
           (mkrec minpt
                  n
                  a
                  h
                  a1
                  h1
                  nil
                  (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
                      (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
                  )
           )
           (setq loop nil)
          )
          (t nil)
    )
  )
  (redraw)
  (mkrec minpt
         n
         a
         h
         a1
         h1
         t
         (or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
             (< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
         )
  )
  (princ)
        )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-26 01:35 , Processed in 0.215242 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表