留言板
- 200853006
- (defun PLConvert (PLEntName / PtsLst0 PtsLst1 MinLeng LinLeng PtsLst2 Pnt0 Pnt1 Pnt2 Pnt3 Pnt4 Pnt5)
;;获取闭合多段线所有顶点的坐标
(setq PtsLst0 (mapcar 'cdr
(vl-remove-if
'(lambda (x) (/= 10 (car x)))
(entget PLEntName)
)
)
;;将起点后置
PtsLst1 (append (cdr PtsLst0) (list (car PtsLst0)))
;;初始化最小长度为闭合多段线的总长
MinLeng (apply '+ (mapcar 'distance PtsLst1 PtsLst0))
;;获取多段线每一段的点对表
PtsLst1 (mapcar 'list PtsLst0 PtsLst1)
)
;;搜索最小长度的那一段
(foreach x PtsLst1
(if (< (setq LinLeng (apply 'distance x)) MinLeng)
(setq MinLeng LinLeng
PtsLst2 x
)
)
)
;;最小长度那一段的前一点
(setq Pnt0 (car PtsLst2)
;;最小长度那一段的后一点
Pnt1 (cadr PtsLst2)
;;最小长度那一段的中点
Pnt2 (mapcar '* (mapcar '+ Pnt0 Pnt1) '(0.5 0.5 0.5))
PtsLst0 (append (member Pnt0 PtsLst0)
(reverse (cdr (member Pnt0 (reverse PtsLst0))))
)
;;循环后置，将Pnt0、Pnt1两点放在点表的后面
PtsLst0 (append (cddr PtsLst0) PtsLst2)
;;初始化变量Pnt3
Pnt3 Pnt1
;;初始化变量PtsLst1，这个变量按顺序保存将要绘制的多段线的所有点
PtsLst1 (list Pnt2)
;;修复部分
Pnt4 (car PtsLst0)
Pnt5 (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.25))
)
(if (setq LinLeng (bpoly Pnt5))
(if (= (vlax-curve-getarea LinLeng)
(vlax-curve-getarea PLEntName)
)
(entdel LinLeng)
(progn
(entdel LinLeng)
(setq PtsLst0 (reverse PtsLst0)
PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0))
Pnt3 Pnt0
Pnt0 Pnt1
)
)
)
(setq PtsLst0 (reverse PtsLst0)
PtsLst0 (append (cddr PtsLst0) (list Pnt1 Pnt0))
Pnt3 Pnt0
Pnt0 Pnt1
)
)
;;如果相对起点Pnt3是最小长度那一段的前一点，那么停止循环
(while (not (equal Pnt3 Pnt0))
;;获取相对终点Pnt4
(setq Pnt4 (car PtsLst0)
;;点Pnt5和点Pnt4一起使用，作为前进或后退的方向
Pnt5 (cadr PtsLst0)
;;根据相对起点Pnt3和相对终点Pnt4的长度和方向移动点Pnt2
Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (distance Pnt3 Pnt4))
)
;;如果移动后点Pnt2在原多段线上，那么先在Pnt3 Pnt4方向上后退半个最小长度，再在Pnt4 Pnt5方向上后退半个最小长度；
;;相反地，点Pnt2不在原多段线上，那么先在Pnt3 Pnt4方向上前进半个最小长度，再在Pnt4 Pnt5方向上前进半个最小长度。
;;这么做的目的是始终使点Pnt2和下一次循环的相对起点保持对齐，距离是半个最小长度，并把两次调整过的点存储到PtsLst1表中。
(if (vlax-curve-getParamAtPoint PLEntName Pnt2)
(setq Pnt2 (polar Pnt2 (angle Pnt4 Pnt3) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt5 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
(setq Pnt2 (polar Pnt2 (angle Pnt3 Pnt4) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
Pnt2 (polar Pnt2 (angle Pnt4 Pnt5) (* MinLeng 0.5))
PtsLst1 (cons Pnt2 PtsLst1)
)
)
;;设置下一次循环的相对起点为这次的相对终点
;;并移除点表的第一项
(setq Pnt3 Pnt4
PtsLst0 (cdr PtsLst0)
)
)
(setq PtsLst1 (reverse PtsLst1)
;;给顶点添加组码10
PtsLst1 (mapcar '(lambda (x) (cons 10 x)) PtsLst1)
;;计算顶点的个数
PtsLst2 (length PtsLst1)
;;添加多段线各段的起点宽度和终点宽度
PtsLst1 (mapcar '(lambda (x) (list (cons 40 MinLeng) (cons 41 MinLeng) x)) PtsLst1)
PtsLst1 (cddr (apply 'append PtsLst1))
)
;;绘制多段线
(entmake
(append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (100 . "AcDbPolyline") (8 . "0") (62 . 6) (70 . 0))
(list (cons 90 PtsLst2))
PtsLst1
)
)
(princ)
)
- 200853006
- 插入文件并更新已有图块定义
http://bbs.mjtd.com/thread-100770-1-1.html
- 200853006
- 标注 不出M 请问有什么技巧吗
- 669423907
- ;φ,M,R 智能标注（ZZXXQQ）2011.5.28
(defun c:cmr()
(setq la (getvar"clayer"))
;(command "clayer" "7标注")
(while (and (setq s1 (entsel "\n选择圆或圆弧 :"))
(setq ent (entget (car s1)))
(wcmatch (setq tn (cdr(assoc 0 ent))) "ARC,CIRCLE"))
(setq pt1 (cadr s1))
(setq qztxt (if (setq qz (getint "\n个数 :")) (strcat (itoa qz) "-") ""))
(if (= tn "ARC") (progn
(setq r (cdr(assoc 40 ent)))
(command ".LENGTHEN" (car s1) "")
(if (>= (/ (getvar "PERIMETER") r) (* 1.49 pi)) (progn
(setq qztxt (strcat qztxt "M" (rtos (+ r r) 2)))
(command "DIMDIAMETER" pt1 "T" qztxt PAUSE))
(command "DIMRADIUS" pt1 "T" (strcat qztxt "<>") PAUSE)))
(command "DIMDIAMETER" pt1 "T" (strcat qztxt "<>") PAUSE)))
;(setvar "clayer"la)
(princ))