批量文字矩形框改为圆，代码问题请教

meja 发表于 2023-6-18 09:21:36

本帖最后由 meja 于 2023-6-18 18:04 编辑

(defun C:TextBox
(/ CurSet CurEnt EntCnt PntLst RecEnt OffDst OffPnt OldCmd OldUci OldUcf)
(setq CurSet
(cond
   ((ssget "_I" '((0 . "TEXT"))))
   (T (prompt "\nTo put boxes around Text,") (ssget '((0 . "TEXT"))))
); cond
); setq
(if CurSet
(progn
   (setq
   OldCmd (getvar "CMDECHO")
   OldUci (getvar "UCSICON")
   OldUcf (getvar "UCSFOLLOW")
   EntCnt 0
   ); setq
   (setvar "CMDECHO" 0)
   (if (= (logand (getvar "UNDOCTL") 4) 4)
   (command "_.UNDO" "_GROUP")
   )
   (setvar "UCSICON" 0)
   (setvar "UCSFOLLOW" 0)
   (repeat (sslength CurSet)
   (setq
      CurEnt (ssname CurSet EntCnt)
      CurEntD (entget CurEnt)
      EntCnt (1+ EntCnt)
   )
   (command "_.UCS" "_OBJ" CurEnt)
   (setq
      PntLst (textbox CurEntD)
      OffPnt (polar (cadr PntLst) 0 1)
      OffDst (* (cdr (assoc 40 CurEntD)) 0.35) ;Distance Text -> Rectangle <--- or 0.5
   ); setq
   (command "_.RECTANGLE" (car PntLst) (cadr PntLst))
   (setq RecEnt (entlast))
   (command
      "_.OFFSET" OffDst RecEnt OffPnt ""
      "_.ERASE" RecEnt ""
      "_.UCS" "_PRE"
   ); command
   ); repeat
   (setvar "UCSICON" OldUci)
   (setvar "UCSFOLLOW" OldUcf)
   (if (= (logand (getvar "UNDOCTL") 4) 4)
   (command "_.UNDO" "_END")
   ); if
   (setvar "CMDECHO" OldCmd)
); progn
); if
(princ)
); defun
官方大神 KENT COOPER 写的。（批量）完美运行，想知道这一句如何改成取中点

(command "_.RECTANGLE" (car PntLst) (cadr PntLst))

xyp1964 发表于 2023-6-20 00:02:26

meja 发表于 2023-6-18 13:16
院长，你这代码十年前就编好了吧，我是来请教改代码的

(defun c:tt ()
(setq i 0)
(if (setq ss (ssget '((0 . "text"))))
(repeat (sslength ss)
   (setq s1 (ssname ss i)
   i (1+ i)
   ptn (textbox (entget s1))
   p10 (cdr (assoc 10 (entget s1)))
   p1 (car ptn)
   p2 (cadr ptn)
   p1 (mapcar '(lambda (x y) (+ x y)) p1 p10)
   p2 (mapcar '(lambda (x y) (+ x y)) p2 p10)
   pc (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
   rr (* (distance p1 p2) 0.5)
   )
   (command "circle" "non" pc rr)
)
)
(princ)
)

xyp1964 发表于 2023-6-21 12:31:19

meja 发表于 2023-6-20 08:33
对你的佩服犹如滔滔江水有本事追加一个对大部分图元（线弧字块）加圆的

(defun c:tt ()
(setq i 0)
(if (setq ss (ssget))
(repeat (sslength ss)
   (setq s1 (ssname ss i)
   i (1+ i)
   ptn (xyp-9ptLIst s1)
   pc (nth 4 ptn)
   rr (* (distance (car ptn) (last ptn)) 0.5)
   )
   (command "circle" "non" pc rr)
)
)
(princ)
)

meja 发表于 2023-6-18 20:46:39

   (setq
      PntLst (textbox CurEntD)
      OffPnt (polar (cadr PntLst) 0 1)
      OffDst (* (cdr (assoc 40 CurEntD)) 0.35) ;Distance Text -> Rectangle <--- or 0.5
      po (MAPCAR '(lambda (X Y ) (* (+ X Y) 0.5)) (car PntLst) (cadr PntLst) )
   ); setq
   (command "_.CIRCLE" po 2 )

正确的写法，搞出来了

xyp1964 发表于 2023-6-18 11:39:44

(defun c:tt ()
"批量文字加圆圈"
(setq i -1)
(if (setq ss (ssget '((0 . "TEXT"))))
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq p5 (xyp-9pt s1 5))
(xyp-CircleCr p5 (distance (xyp-9pt s1 7) p5))
)
)
(princ)
)

meja 发表于 2023-6-18 13:16:42

xyp1964 发表于 2023-6-18 11:39

院长，你这代码十年前就编好了吧:D-，我是来请教改代码的

start4444 发表于 2023-6-18 16:11:40

(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗

meja 发表于 2023-6-18 18:02:39

start4444 发表于 2023-6-18 16:11
(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗

这种列表型我不太会改了。我只会改pt1和PT2的那种。可以指教怎么写吗？

meja 发表于 2023-6-18 20:36:44

start4444 发表于 2023-6-18 16:11
(car PntLst) (cadr PntLst) 这就是矩形的对角点，找中点不是很简单吗

(command "_.CIRCLE" (* 0.5 (+ (car (car PntLst)) (car (cadr PntLst))) ) (* 0.5 (+ (cadr (car PntLst)) (cadr (cadr PntLst)))) (- (cadr (cadr PntLst)) (cadr (car PntLst)) ) ) 改了，还是有问题

依然小小鸟 发表于 2023-6-18 21:00:02

meja 发表于 2023-6-18 20:46
正确的写法，搞出来了

有最终组合再一起的完整代码吗

meja 发表于 2023-6-18 21:32:13

依然小小鸟发表于 2023-6-18 21:00
有最终组合再一起的完整代码吗

你覆盖一楼代码30-35行即可，代码用来学习的，经常犯错误才能改进:L

MZ_li 发表于 2023-6-19 09:54:30

meja 发表于 2023-6-18 21:32
你覆盖一楼代码30-35行即可，代码用来学习的，经常犯错误才能改进

你这段的加圆不能圈在文字外框

页: [1] 2

明经CAD社区's Archiver

批量文字矩形框改为圆，代码问题请教