明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2168|回复: 25

[源码] 外围轮廓线(支持块样条曲线椭圆)

  [复制链接]
发表于 2024-7-28 15:15:36 | 显示全部楼层 |阅读模式
编了一个区域覆盖程序,本来用了李麦克的外围轮廓线程序,但是不支持样条曲线和椭圆,挺苦恼。于是就自己操刀编了一个支持的。实际运行简单图形还行复杂的速度慢,也没其它办法。将就用吧。


;;; 外轮廓线,返回轮廓拟合线点列表,支持样条曲线,椭圆,块。
(defun outline (ss / alst ar b e1 e2 en en1 en2 en3 ent f i ii j lst lst1 lstx lsty maxpoint minpoint name name1 obj pmax pmin pt
                   snap ss2 ss3 ss4 vc vh vs x zw
               )
  (defun ssnext (en / ss)
    (setq ss (ssadd))
    (while (setq en (entnext en))
      (if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
        (setq ss (ssadd en ss))
      )
    )
    ss
  )
  (vl-load-com)
  (setq snap (getvar "osmode"))
  (setvar "osmode" 0)
  (setq lstx '()
        lsty '()
  )
  (setq en1 (entlast))
  (repeat (setq i (sslength ss))       ; 计算ss最大外围框
    (setq name (ssname ss (setq i (1- i))))
    (vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
    (setq pmax (vlax-safearray->list maxpoint)
          pmin (vlax-safearray->list minpoint)
          lstx (cons (car pmin) (cons (car pmax) lstx))
          lsty (cons (cadr pmin) (cons (cadr pmax) lsty))
    )
  )
  (setq lstx (vl-sort lstx '<)
        lsty (vl-sort lsty '<)
  )
  (setq b (* 0.1 (max
                   (- (last lstx) (car lstx))
                   (- (last lsty) (car lsty))
                 )
          )
  )
  (setq lst (list (list (- (car lstx) b) (- (car lsty) b)) (list (+ (last lstx) b) (- (car lsty) b)) (list (+ (last lstx) b)
                                                                                                           (+ (last lsty) b)
                                                                                                     ) (list (- (car lstx) b)
                                                                                                             (+ (last lsty) b)
                                                                                                       )
            )
  )
  (entmake (append
             (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 1))
             (mapcar
               '(lambda (pt)
                  (cons 10 pt)
                )
               lst
             )
           )
  )                                       ; 生成大一点的外围框
  (setq vc (trans (getvar "viewctr") 1 2) ; 计算当前窗口坐标用于放大窗口
        vh (getvar "viewsize")
        vs (mapcar
             '/
             (list (* (apply
                        '/
                        (getvar "screensize")
                      ) vh
                   ) vh
             )
             '(2 2)
           )
  )
  (setq zw (mapcar
             '(lambda (f)
                (trans (mapcar
                         f
                         vc
                         vs
                       ) 2 1
                )
              )
             '(- +)
           )
  )
  (vl-cmdf "ZOOM" "W" (list (- (car lstx) b) (- (car lsty) b)) (list (+ (last lstx) b) (+ (last lsty) b))) ; 放大窗口
  (setq ss (ssadd (entlast) ss))
  (setq pt (list (- (car lstx) (* 0.5 b)) (- (car lsty) (* 0.5 b))))
  (setq en2 (entlast))
  (vl-cmdf "boundary" "A" "O" "R" "B" "N" ss "" "" pt "") ; 生成面域
  (vl-cmdf "ZOOM" "W" (car zw) (cadr zw)) ; 恢复原窗口
  (setq alst '())
  (if (setq ss2 (ssnext en2))
    (progn
      (repeat (setq i (sslength ss2))
        (setq name (ssname ss2 (setq i (1- i))))
        (if (= (cdr (assoc 0 (entget name))) "REGION")
          (setq obj (vlax-ename->vla-object name)
                ar (vla-get-area obj)
                alst (cons (list ar name) alst)
          )
        )
      )
      (setq alst (vl-sort alst (function (lambda (e1 e2)
                                           (> (car e1) (car e2))
                                         )
                               )
                 )
      )
      (setq alst (cdr alst))
      (setq ss4 (ssadd))
      (if (car alst)
        (progn
          (setq name (cadr (car alst)))        ; 取第二大面积,第一大为外围框不选用
          (setq en3 (entlast))
          (vl-cmdf "explode" name)     ; 炸开面域
          (if (setq ss3 (ssnext en3))
            (repeat (setq j (sslength ss3))
              (setq name1 (ssname ss3 (setq j (1- j))))
              (setq obj (vlax-ename->vla-object name1))
              (setq ent (entget name1))
              (if (member (cdr (assoc 0 ent)) (list "SPLINE" "CIRCLE" "ARC" "ELLIPSE"))        ; 如果线是样条椭圆圆圆弧生成拟合线
                (progn
                  (setq lst (list (vlax-curve-getstartpoint obj)))
                  (setq b (* 0.02 (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
                  (setq ii 1)
                  (repeat 49
                    (setq lst (cons (vlax-curve-getpointatdist obj (* ii b)) lst))
                    (setq ii (1+ ii))
                  )
                  (setq lst (cons (vlax-curve-getendpoint obj) lst))
                  (entmake (append
                             (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)))
                             (mapcar
                               '(lambda (pt)
                                  (cons 10 pt)
                                )
                               lst
                             )
                           )
                  )
                  (setq ss4 (ssadd (entlast) ss4))
                )
                (setq ss4 (ssadd name1 ss4))
              )
            )
          )
          (setvar "peditaccept" 1)
          (vl-cmdf "PEDIT" "M" ss4 "" "J" 0.1 "") ; 将外围线连接成一条多段线,并取端点
          (setq lst1 (mapcar
                       'cdr
                       (vl-remove-if-not '(lambda (x)
                                            (= (car x) 10)
                                          ) (entget (entlast))
                       )
                     )
          )
        )
      )
      (vl-cmdf "erase" (ssnext en1) "")        ; 删除过程中产生的所有图元
    )
  )
  (setvar "osmode" snap)
  lst1
)
;;; 测试1:生成外围轮廓线
(defun c:aa (/ lst pt ss)
  (if (setq ss (ssget '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,INSERT"))))
    (progn
      (setq lst (outline ss))
      (entmake (append
                 (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 1)
                       (cons 62 1)
                 )
                 (mapcar
                   '(lambda (pt)
                      (cons 10 pt)
                    )
                   lst
                 )
               )
      )
    )
  )
  (princ)
)
;;; 测试2:区域覆盖
(defun c:bb (/ #err $orr cp h i lenid ll lst n pt pts s1 snap ss ur w wh)
  (defun gxl-makewipeout (pts / cp h lenid ll lst pt ur w wh) ; 点表转区域覆盖
    (setq lenid (strlen (vl-princ-to-string (vlax-get-acad-object))))
    (cond
      ((= lenid 39)                       ; =>39就是32位AutoCAD
        (if (not (member "acwipeout.arx" (arx)))
          (arxload "acwipeout.arx")
        )
      )
      ((eq 47 lenid)                       ; =>47就是47位autocad
        (if (not (member "acismui.arx" (arx)))
          (arxload "acismui.arx")
        )
      )
    )
    (if (not (equal (car pts) (last pts) 1e-6))
      (setq pts (cons (last pts) pts))
    )
    (setq ll (apply
               'mapcar
               (cons 'min pts)
             )
          ur (apply
               'mapcar
               (cons 'max pts)
             )
          wh (mapcar
               '-
               ur
               ll
             )
          w (car wh)
          h (cadr wh)
          cp (mapcar
               '*
               (mapcar
                 '+
                 ll
                 ur
               )
               '(0.5 0.5 0.5)
             )
    )
    (foreach pt pts
      (setq lst (cons (list 14 (/ (car (setq pt (mapcar
                                                  '-
                                                  pt
                                                  cp
                                                )
                                       )
                                  ) w
                               ) (- (/ (cadr pt) h))
                      ) lst
                )
      )
    )
    (setq lst (reverse lst))
    (entmakex (append
                (list '(0 . "WIPEOUT") '(100 . "AcDbEntity") '(100 . "AcDbWipeout") (cons 10 ll) (list 11 w 0.0) (list 12 0.0 h) '
                      (280 . 1) '(71 . 2)
                )
                lst
              )
    )
  )
  (defun #err (s / i n s1)               ; 出错处理子函数
    (setvar "osmode" snap)
    ((if command-s
       command-s
       vl-cmdf
     ) ".undo"
     "e"
    )
    (setq *error* $orr)
  )
  (vl-load-com)
  (vl-cmdf ".UNDO" "BE")               ; 设置undo起点
  (setvar "cmdecho" 0)
  (setq snap (getvar "osmode"))
  (setvar "osmode" 0)
  (setq $orr *error*)
  (setq *error* #err)
  (if (setq ss (ssget '((0 . "*LINE,CIRCLE,ARC,ELLIPSE,INSERT"))))
    (progn
      (setq lst (outline ss))
      (gxl-makewipeout lst)
      (setq name (entlast))
      (vl-cmdf "draworder" name "" "B")
      (vl-cmdf "draworder" ss name "" "F")
    )
  )
  (setvar "osmode" snap)
  (setq *error* $orr)
  (vl-cmdf ".UNDO" "E")                       ; 设置undo终点
  (princ)
)


评分

参与人数 7明经币 +7 金钱 +10 收起 理由
alexmai + 1 + 5 不会写,一直想拥有的小程序,赞一个
ymcui + 1 赞一个!
USER2128 + 1 很给力!
jltx123456 + 1 赞一个!
tigcat + 1 + 5 很给力!
天天问 + 1 很给力!
xj6019 + 1 赞一个!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2024-7-28 21:20:04 | 显示全部楼层
回复 支持 1 反对 0

使用道具 举报

发表于 2024-7-28 15:31:38 | 显示全部楼层
有spline时影响精度,最好用面域处理
回复 支持 0 反对 1

使用道具 举报

发表于 3 天前 | 显示全部楼层
本帖最后由 llsheng_73 于 2024-12-24 21:11 编辑
xyp1964 发表于 2024-12-24 13:58
;; 最好能保持原曲线属性

这个很牛,是直接生成的面域么?所以最后炸开都是原图形的一部分?
先全部转成面域,合并成一个得到outline?

点评

bpoly → 面域  发表于 3 天前
回复 支持 反对

使用道具 举报

发表于 2024-7-28 16:00:18 | 显示全部楼层
刚才试了下  怎么圆弧都变成直线了

本帖子中包含更多资源

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

x
发表于 2024-7-28 16:44:01 | 显示全部楼层
刚试了下,圆弧是变成小段小段直线组成,精度有点影响,但问题不大,基本满足一般图形处理了,感谢楼主分享。。。
 楼主| 发表于 2024-7-28 18:12:01 | 显示全部楼层
圆弧是变成小段小段直线的原因是做区域覆盖用的。如果目的不是区域覆盖,稍微改一下就行了
发表于 2024-7-28 19:01:18 | 显示全部楼层
感谢大师的作品,非常好用
发表于 2024-7-28 19:02:15 | 显示全部楼层
大佬出手必属精品,感谢分享
发表于 2024-7-28 19:18:54 | 显示全部楼层
支持狼大师..........
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-12-27 10:31 , Processed in 0.213870 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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