@hvac:batch-dim-pipe

说明:管件

用法:

 (@hvac:batch-dim-pipe)

参数:

返回值:

示例:

(defun @hvac:batch-dim-pipe ()
  (@:help'("批量标地暖管的间距和分支长度,未成功标注的将地暖管改为红色。"))
  (@:prompt "请框选地暖管:")
  (if (setq pipe-s (pickset:to-list (ssget  '((0 . "lwpolyline")(8 . "*地暖*")))))
      (progn
	(setq ents
	      (vl-remove
	       nil
	       (mapcar
		'(lambda(pipe-d)
		  (if (> (setq len (* 0.001 (curve:length pipe-d))) 5)
		      (progn
			(if (< (- len (fix len)) 0.4)
			    (setq len (+ (fix len) 1.0))
			    (setq len (+ (fix len) 1.5)))
			;; 找水平线的中点			(setq pt-s (curve:midpoint pipe-d))
			(while (and pt-s
				   (or
				    (="arc"(curve:subsegment-picked-type pipe-d pt-s))
				    (not (and (cadr (curve:subsegment-picked-points pipe-d pt-s))
					      (or (equal 0 (apply 'angle (curve:subsegment-picked-points pipe-d pt-s))
							 0.01)
						  (equal pi (apply 'angle (curve:subsegment-picked-points pipe-d pt-s))
							 0.01))))
				    ))
			  (setq pt-s (cadr (curve:subsegment-picked-points pipe-d pt-s))))
			(if (and pt-s (cadr (curve:subsegment-picked-points pipe-d pt-s)))
			    (progn
			      (setq pt-s (apply 'point:mid (curve:subsegment-picked-points pipe-d pt-s)))
			      (setq pt-d (polar pt-s (* 1.5 pi) 6000))
			      (setq line-t (entity:make-line pt-s pt-d))
			      (setq pt-inters (vl-sort (curve:inters (e2o pipe-d)(e2o line-t) acExtendNone)
						       '(lambda(x y)
							 (> (cadr x)(cadr y)))))
			      (entdel line-t)
			      ;; 计算间距			      (setq d (if (and pt-inters
					       (> (length pt-inters) 1))
					  (car (stat:mode (stat:stat (mapcar 'fix (mapcar 'distance pt-inters (cdr pt-inters))))))))
			      (setq ml
				    (entity:make-multileader
				     (list pt-s pt-d)
				     (strcat "D="(if d (itoa d)"{\\C1;***}")"mm\\PL="
					     (string:number-format
					      (rtos len 2 1)
					      2 1 " 0")
					     "m")))
			      (vla-put-ScaleFactor (e2o ml)
						   (* 10 (@:get-config '@::draw-scale)))
			      ml)
			    (progn (entity:putdxf pipe-d 62 1) nil)
			    ))
		      (progn (entity:putdxf pipe-d 62 1) nil)
		      ))
		pipe-s)))
	(setq flag t)
	(if (p:ename-listp ents)
	    (progn
	      (while flag
		(setq gr (grread t 16))
		(cond
		  ((= 3 (car gr))
		   "按下鼠标左键"
		   ;;绘制并退出		   (setq flag nil)
		   )
		  ((or (= 25 (car gr))
		       (= 11 (car gr)))
		   "按下鼠标右键"
		   ;; 删除并退出		   (mapcar 'entdel ents)
		   (setq ents  nil)
		   (setq flag nil)
		   )
		  ((= 5 (car gr))
		   "移动鼠标"
		   (mapcar (function(lambda(x)
			     (setq pt-ml (entity:getdxf x 10))
			     (@hvac:move-pt-base
			      x
			      (list
			       (list (car (nth 0 pt-ml))
				     (cadr (cadr gr))
				     0)
			       (list (car (nth 0 pt-ml))
				     (+ 450 (cadr (cadr gr)))
				     0)
			       (list (car (nth 1 pt-ml))
				     (cadr (cadr gr))
				     0)
			       (nth 2 pt-ml)
			       (nth 3 pt-ml)))
			     ))
			   ents)
		   ;; (setq pt-base (cadr gr))		   )
		  (t "其它情况"
		     (princ gr)))
		)
	      ents
	      )
	    ))
      )
  )

@lisp 函数库

介绍

调用函数

安装教程

快速上手：

@hvac:batch-dim-pipe

上传记录