[源码]批量绘制直线中垂线

荒野孤行 · 发表于 2013-9-8 20:40

本帖最后由荒野孤行于 2023-7-12 18:50 编辑

;;;***********绘制直线的中垂线程序开始************
(defun c:zcx ()
  (setvar "pickadd" 1)
  (setvar "osmode" 15359)
  (setvar "cmdecho" 0)
  (command "undo" "be")
  (princ "\n★功能:批量绘制直线的中垂线.")
  (setq ss (ssget '((0 . "LINE"))))
  (if (null ss)
(progn (princ "\n★提示:未选取直线!") (exit))
  )
  (setq n (sslength ss))
  (setq i 0)
  (setvar "osmode" 0)
  (while (< i n)
(setq entname (ssname ss i))
(setq entdata (entget entname))
(setq i (+ i 1))
(setq ptqd (cdr (assoc 10 entdata)))
(setq ptzd (cdr (assoc 11 entdata)))
(setq dist (distance ptqd ptzd))
(setq ang (angle ptqd ptzd))
(setq ptqdx (car ptqd))
(setq ptqdy (cadr ptqd))
(setq ptzdx (car ptzd))
(setq ptzdy (cadr ptzd))
(setq ptzxx (/ (+ ptqdx ptzdx) 2))
(setq ptzxy (/ (+ ptqdy ptzdy) 2))
(setq
   pt1 (polar (list ptzxx ptzxy) (+ ang (angtof "90")) (/ dist 2))
)
(setq
   pt2 (polar (list ptzxx ptzxy) (+ ang (angtof "-90")) (/ dist 2))
)
(command "LAYER" "M" "中垂线" "C" "RED" "中垂线" "")
(command "COLOR" "Bylayer")
(command "LINE" pt1 pt2 "")
  )
  (command "undo" "e")
  (setvar "osmode" 15359)
  (princ)
)
;;;**************绘制直线的中垂线程序结束**************

恕放之生命 · 发表于 2014-8-20 19:28

谢谢分享。

lucas_3333 · 发表于 2014-8-20 19:30

本帖最后由 lucas_3333 于 2014-8-20 19:48 编辑

只支持直线
http://bbs.mjtd.com/thread-95149-1-1.html

lgflysnow · 发表于 2018-1-14 03:40

如果多些选择就更好了

yoyoho · 发表于 2018-1-14 08:49

谢谢! 荒野孤行分向程序!!!

zhangkui9070 · 发表于 2023-5-3 18:37

感谢分享，正好需要

ninja37 · 发表于 2023-5-5 18:56

谢谢分享

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

[源码] [源码]批量绘制直线中垂线