设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 等分矩形
123下一页
返回列表 发新帖
查看: 2496|回复: 23

[源码] 等分矩形

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


本帖子中包含更多资源

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

x

评分

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

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

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

本帖子中包含更多资源

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

x
回复 支持 0 反对 1

使用道具 举报

qianyi0710
发表于 2021-9-5 22:06 | 显示全部楼层
kkq0305 发表于 2021-9-5 01:47

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


(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)
)
回复 支持 反对

使用道具 举报

999999
发表于 2021-9-4 17:15 | 显示全部楼层
板凳端上，，  谢谢楼主分享
回复 支持 反对

使用道具 举报

纵横八方
发表于 2021-9-4 18:07 来自手机 | 显示全部楼层
漂亮的很哦

点评

kkq0305
q:1016769094  发表于 2021-9-5 13:30
回复 支持 反对

使用道具 举报

xj6019
发表于 2021-9-4 20:11 | 显示全部楼层
膜拜大佬，感谢分享，收下学习了
回复 支持 反对

使用道具 举报

sdbaijiao
发表于 2021-9-5 19:51 | 显示全部楼层
谢谢楼主的分享。。。。
回复 支持 反对

使用道具 举报

qianyi0710
发表于 2021-9-5 20:52 | 显示全部楼层
本帖最后由 qianyi0710 于 2021-9-5 21:00 编辑
kkq0305 发表于 2021-9-5 01:47

非常感谢，下载下来学习下，(格子间距)   要是独立直线就好。要是直线就完美了。
回复 支持 反对

使用道具 举报

kkq0305
 楼主| 发表于 2021-9-6 02:45 | 显示全部楼层
(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
回复 支持 反对

使用道具 举报

123下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-7-3 09:14 , Processed in 0.171010 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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