|
帮网上一个朋友做的一个坐标自动标注程序，虽然解决了大部分问题，但是还有少量缺点，弄不起来了，希望高手指点： 主要集中两点：1。程序不能把坐轴移动到标注基点上 2。程序运行时候，多数情况正常，但是偶尔有时候会出现“未知命令”情况，找不到原因 ;;; =================================================================
;;; 自动坐标标注
;;; 原作者：zml84 由langjs修改于2009-05-25 命令：tt
;;; =================================================================
(princ "\n 自动坐标标注 命令:tt ")
(defun C:TT (/ chanshu001 ent ent1 i lst_1 lst_2 lst_3 lst_4 lst_pt lst_x lst_y p001 p002 p003 p004
pmax pmay pminx pminy pt0 pzhx pzhxl pzhy pzhyl sc snap ss ssguol uuu x_last xlins
xxxx xzuih xzuihbak xzuihbak2 y_last ylins yyyy yzuih yzuihbak3 PT0linshijidian
)
(setvar "cmdecho" 0) ; 关闭命令响应
(setq ss (ssget '((0 . "LINE,CIRCLE,PLINE,LWPOLYLINE,INSERT"))))
(setq PT0linshijidian '(0.0 0.0 0.0))
(setq PT0 (getpoint "\n指定基点: "))
(cond
((null PT0)
(setq PT0 PT0linshijidian)
)
((= PT0 0.0)
(setq PT0 PT0linshijidian)
)
)
(setq SC 1)
(setq SC (getreal "\n输入比例 <1>: "))
(cond
((null SC)
(setq SC 1)
)
((= uuu 0.0)
(setq SC 1)
)
)
(setq chanshu001 (* 7 (getvar "dimtxt") (getvar "dimscale")))
(setq uuu (atof (getstring (strcat "\n标注拉伸 <" (rtos chanshu001) ">:"))))
(cond
((null uuu)
(setq uuu chanshu001)
)
((= uuu 0.0)
(setq uuu chanshu001)
)
) ; 下面程序设置过滤虚线条件
(setq ssguol '("ACAD_ISO03W100" "ACAD_ISO02W100"
"DASHED" "DASHED2"
"DASHEDX2" "HIDDEN"
"HIDDEN2" "HIDDENX2"
)
) ; 下面程序将虚线图层加入虚线过滤条件
(setq ssguol (append
SSguol
(TT-01 "ACAD_ISO03W100")
(TT-01 "ACAD_ISO02W100")
(TT-01 "DASHED")
(TT-01 "DASHED2")
(TT-01 "DASHEDX2")
(TT-01 "HIDDEN")
(TT-01 "HIDDEN2")
(TT-01 "HIDDENX2")
)
) ; 下面程序将选择集中随层的虚线图层中的线过滤掉
(SETQ i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (and
(member (cdr (assoc 8 ent1)) ssguol)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(setq ss (ssdel ent ss))
(SETQ i (+ 1 i))
)
) ; 下面程序将选择集中其他层的虚线图元过滤掉
(SETQ i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (member (cdr (assoc 6 ent1)) ssguol)
(setq ss (ssdel ent ss))
(SETQ i (+ 1 i))
)
) ; 主要程序
(vl-cmdf ".UNDO" "BE") ; 设置UNDO起点
(setq snap (getvar "osmode"))
(setvar "osmode" 0) ; 关闭捕捉
(progn
(setq LST_PT (TT-02 ss))
(setq LST_PT (cons PT0 LST_PT)) ; 下面程序坐标分象限
(setq i 1
pminx (car (nth 0 LST_PT))
pmax pminx
pminy (cadr (nth 0 LST_PT))
pmay pminy
)
(while (<= i (length LST_PT))
(setq xxxx (car (nth (- i 1) LST_PT)))
(setq yyyy (cadr (nth (- i 1) LST_PT)))
(cond
((< xxxx pminx)
(setq pminx xxxx)
)
((> xxxx pmax)
(setq pmax xxxx)
)
((< yyyy pminy)
(setq pminy yyyy)
)
((> yyyy pmay)
(setq pmay yyyy)
)
(t
(princ)
)
)
(setq i (+ i 1))
) ; 求坐标范围中间数值
(setq pzhx (/ (+ pminx pmax) 2))
(setq pzhy (/ (+ pminy pmay) 2)) ; 求4个象限的坐标对齐点
(setq p001 (list (- pminx uuu) (- pminy uuu) 0.0)
p002 (list (- pminx uuu) (+ pmay uuu) 0.0)
p003 (list (+ pmax uuu) (- pminy uuu) 0.0)
p004 (list (+ pmax uuu) (+ pmay uuu) 0.0)
) ; 将坐标分类到四个象限
(setq i 0
LST_1 '()
LST_2 '()
LST_3 '()
LST_4 '()
)
(while (< i (length LST_PT))
(setq pzhxl (car (nth i LST_PT))
pzhyl (cadr (nth i LST_PT))
)
(if (and
(<= pzhxl pzhx)
(<= pzhyl pzhy)
)
(setq LST_1 (cons (nth i LST_PT) LST_1))
)
(if (and
(<= pzhxl pzhx)
(> pzhyl pzhy)
)
(setq LST_2 (cons (nth i LST_PT) LST_2))
)
(if (and
(> pzhxl pzhx)
(<= pzhyl pzhy)
)
(setq LST_3 (cons (nth i LST_PT) LST_3))
)
(if (and
(> pzhxl pzhx)
(> pzhyl pzhy)
)
(setq LST_4 (cons (nth i LST_PT) LST_4))
)
(setq i (+ i 1))
) ; 坐标分象限结束
(setq Xlins '(0.0)
Ylins '(0.0)
)
(setq LST_X (TT-03 LST_1)
LST_Y (TT-04 LST_1)
)
(setq LST_X (TT-10 SS LST_X)
LST_Y (TT-11 SS LST_Y)
)
(setq X_LAST (caar LST_X))
(setq Y_LAST (caar LST_Y))
(TT-07 LST_X LST_Y PT0 SC p001)
(setq Xzuihbak Xzuih)
(setq LST_X (TT-05 LST_2)
LST_Y (TT-04 LST_2)
)
(setq LST_X (TT-10 SS LST_X)
LST_Y (TT-11 SS LST_Y)
)
(setq X_LAST (caar LST_X))
(TT-07 LST_X LST_Y PT0 SC p002)
(setq Xzuihbak2 Xzuih)
(setq Yzuihbak2 Yzuih)
(setq LST_X (TT-03 LST_3)
LST_Y (TT-06 LST_3)
)
(setq LST_X (TT-10 SS LST_X)
LST_Y (TT-11 SS LST_Y)
)
(setq X_LAST Xzuihbak)
(setq Y_LAST (caar LST_Y))
(TT-07 LST_X LST_Y PT0 SC p003)
(setq Yzuihbak3 Yzuih)
(setq X_LAST Xzuihbak2)
(setq LST_X (TT-05 LST_4)
LST_Y (TT-06 LST_4)
)
(if (= Yzuihbak2 Yzuihbak3)
(setq Y_LAST (caar LST_Y))
(setq Y_LAST Yzuihbak3)
)
(setq LST_X (TT-10 SS LST_X)
LST_Y (TT-11 SS LST_Y)
)
(TT-07 LST_X LST_Y PT0 SC p004)
)
(vl-cmdf ".UNDO" "E") ; 设置UNDO终点
(setvar "osmode" snap)
(princ)
)
;;; =================================================================
;;; 获取包含指定线型的图层
(defun TT-01 (xianxing / layers)
(setq layers '())
(setq layers (get_layer_linetype xianxing)) ; 获取包含指定线型的图层
layers
)
(defun get_layer (/ layer_info layers) ; 返回当前图纸中图层信息
(setq layer_info (tblnext "layer" t))
(while (/= layer_info nil)
(setq layers (append
layers
(list layer_info)
)
)
(setq layer_info (tblnext "layer"))
)
layers
)
(defun get_layer_linetype (linetype / ly_info ly_infos tmplist) ; 提取包含指定线型的图层
(setq ly_Infos (get_layer))
(foreach ly_info ly_Infos
(if (= linetype (substr (cdr (assoc 6 ly_info)) 1 (strlen linetype)))
(setq tmplist (append
tmplist
(list (CDR (assoc 2 ly_info)))
)
)
)
)
tmplist
)
;;; =================================================================
;;; 获取特征点坐标
(defun TT-02 (SS / ent i lst_pt lstl n pt)
(setq LST_PT '()
I 0
)
(repeat (sslength SS)
(setq ENT (entget (ssname SS I)))
(foreach N ENT
(if (<= 10 (car N) 19)
(setq PT (cdr N)
LST_PT (cons PT LST_PT)
)
)
)
(setq I (1+ I))
)
(setq i 0
LSTL '()
)
(while (< i (length LST_PT))
(setq LSTL (cons (list (car (nth i LST_PT)) (cadr (nth i LST_PT)) 0.0) LSTL))
(setq i (+ 1 i))
)
(setq LST_PT LSTL) ; 返回
(reverse LST_PT)
)
;;; =================================================================
;;; 提炼 X 坐标，并排序
(defun TT-03 (LST_PT / e1 e2 i lst_x lstl pt tmp x y)
(setq LST_X '())
(foreach PT LST_PT
(setq X (car PT)
Y (cadr PT)
)
(if (setq TMP (assoc X LST_X))
(setq LST_X (subst
(append
(list X Y)
(cdr TMP)
)
TMP
LST_X
)
)
(setq LST_X (cons (list X Y) LST_X))
)
) ; 排序
(setq LST_X (mapcar
'(lambda (E1)
(cons (car E1) (vl-sort (cdr E1) '<))
)
LST_X
)
)
(setq LST_X (vl-sort LST_X '(lambda (E1 E2)
(< (car E1) (car E2))
)
)
)
(setq i 0
LSTL '()
)
(while (< i (length LST_X))
(setq LSTL (cons (list (car (nth i LST_X)) (cadr (nth i LST_X)) 0.0) LSTL))
(setq i (+ 1 i))
)
(setq LST_X (reverse LSTL)) ; 返回
LST_X
)
;;; =================================================================
;;; 提炼 Y 坐标，并排序
(defun TT-04 (LST_PT / e1 e2 i lst_y lstl pt tmp x y)
(setq LST_Y '())
(foreach PT LST_PT
(setq X (car PT)
Y (cadr PT)
)
(if (setq TMP (assoc Y LST_Y))
(setq LST_Y (subst
(append
(list Y X)
(cdr TMP)
)
TMP
LST_Y
)
)
(setq LST_Y (cons (list Y X) LST_Y))
)
) ; 排序
(setq LST_Y (mapcar
'(lambda (E1)
(cons (car E1) (vl-sort (cdr E1) '<))
)
LST_Y
)
)
(setq LST_Y (vl-sort LST_Y '(lambda (E1 E2)
(< (car E1) (car E2))
)
)
)
(setq i 0
LSTL '()
)
(while (< i (length LST_Y))
(setq LSTL (cons (list (car (nth i LST_Y)) (cadr (nth i LST_Y)) 0.0) LSTL))
(setq i (+ 1 i))
)
(setq LST_Y (reverse LSTL)) ; 返回
LST_Y
)
;;; =================================================================
;;; 提炼 X 坐标，并排序 (由大到小)
(defun TT-05 (LST_PT / e1 e2 i lst_x lstl pt tmp x y)
(setq LST_X '())
(foreach PT LST_PT
(setq X (car PT)
Y (cadr PT)
)
(if (setq TMP (assoc X LST_X))
(setq LST_X (subst
(append
(list X Y)
(cdr TMP)
)
TMP
LST_X
)
)
(setq LST_X (cons (list X Y) LST_X))
)
) ; 排序
(setq LST_X (mapcar
'(lambda (E1)
(cons (car E1) (vl-sort (cdr E1) '<))
)
LST_X
)
)
(setq LST_X (vl-sort LST_X '(lambda (E1 E2)
(< (car E1) (car E2))
)
)
)
(setq i 0
LSTL '()
)
(while (< i (length LST_X))
(setq LSTL (cons (list (car (nth i LST_X)) (nth (- (length (nth i LST_X)) 1) (nth i LST_X)) 0.0)
LSTL
)
)
(setq i (+ 1 i))
)
(setq LST_X (reverse LSTL)) ; 返回
LST_X
)
;;; =================================================================
;;; 提炼 Y 坐标，并排序 (由大到小)
(defun TT-06 (LST_PT / e1 e2 i lst_y lstl pt tmp x y)
(setq LST_Y '())
(foreach PT LST_PT
(setq X (car PT)
Y (cadr PT)
)
(if (setq TMP (assoc Y LST_Y))
(setq LST_Y (subst
(append
(list Y X)
(cdr TMP)
)
TMP
LST_Y
)
)
(setq LST_Y (cons (list Y X) LST_Y))
)
) ; 排序
(setq LST_Y (mapcar
'(lambda (E1)
(cons (car E1) (vl-sort (cdr E1) '<))
)
LST_Y
)
)
(setq LST_Y (vl-sort LST_Y '(lambda (E1 E2)
(< (car E1) (car E2))
)
)
)
(setq i 0
LSTL '()
)
(while (< i (length LST_Y))
(setq LSTL (cons (list (car (nth i LST_Y)) (nth (- (length (nth i LST_Y)) 1) (nth i LST_Y)) 0.0)
LSTL
)
)
(setq i (+ 1 i))
)
(setq LST_Y (reverse LSTL)) ; 返回
LST_Y
)
;;; =================================================================
;;; 标注
(defun TT-07 (LST_X LST_Y PT0 SC ppp / ent pt pt1 str tmp x y) ; 标注 X
(foreach TMP LST_X
(setq X (car TMP)
Y (cadr TMP)
PT (list X Y 0.0)
STR (rtos (* SC (- X (car PT0))))
)
(if (and
(/= (TT-09 X 4) (TT-09 (car Xlins) 4))
(not (member (TT-09 X 4) Xlins))
)
(progn
(setq X_LAST (max
X
X_LAST
)
PT1 (list X_LAST (- (cadr PT0) (* 1.0 SC)) 0.0) ; _标注点
X_LAST (+ X_LAST (* 2 (getvar "dimtxt") (getvar "dimscale")))
)
(setq Xlins (cons (TT-09 X 4) Xlins))
(setq Xzuih X_LAST)
(princ "\n标注X坐标，坐标点")
(princ PT)
(vl-cmdf "_dimordinate" PT "x" "t" STR PT1) ;;标注负号
;;;; (vl-cmdf "_dimordinate" PT "x" "t" (rtos (abs (atof STR))) PT1) ;;不标注负号
(setq ent (entlast))
(TT-08 ent ppp PT0) ; 对齐坐标
)
)
) ; 标注 Y
(foreach TMP LST_Y
(setq Y (car TMP)
X (cadr TMP)
PT (list X Y 0.0)
STR (rtos (* SC (- Y (cadr PT0))))
)
(if (and
(/= (TT-09 Y 4) (TT-09 (car Ylins) 4))
(not (member (TT-09 Y 4) Ylins))
)
(progn
(setq Y_LAST (max
Y
Y_LAST
)
PT1 (list (- (car PT0) (* 1.0 SC)) Y_LAST 0.0) ; _标注点
Y_LAST (+ Y_LAST (* 2 (getvar "dimtxt") (getvar "dimscale")))
)
(setq Ylins (cons (TT-09 Y 4) Ylins))
(setq Yzuih Y_LAST)
(princ "\n标注Y坐标，坐标点")
(princ PT)
(vl-cmdf "_dimordinate" PT "Y" "t" STR PT1) ;;标注负号
;;;; (vl-cmdf "_dimordinate" PT "Y" "t" (rtos (abs (atof STR))) PT1) ;;不标注负号
(setq ent (entlast))
(TT-08 ent ppp PT0) ; 对齐坐标 )
)
)
)
;;; =================================================================
;;; 点坐标对齐
(defun TT-08 (ent p0 PT0 / np14 p0x p0y p14x p14y p70) ; 点坐标对齐
(setq ent (entget ent))
(setq p70 (cdr (assoc 70 ent))
p14x (car (cdr (assoc 14 ent)))
p14y (cadr (cdr (assoc 14 ent)))
)
(setq p0x (car p0)
p0y (cadr p0)
)
(cond
((= p70 38.0)
(setq np14 (list p0x p14y 0.0))
)
((= p70 102.0)
(setq np14 (list p14x p0y 0.0))
)
(t
(exit)
)
)
(setq ent (subst
(cons 14 nP14)
(assoc 14 ent)
ent
)
)
(setq ent (subst
(cons 10 PT0)
(assoc 10 ent)
ent
)
)
(entmod ent)
(princ)
)
;;; =================================================================
;;; 四舍五入函数，ent:实数，n：小数点保留位数
(defun TT-09 (ent n / fh)
(if (>= ent 0.0)
(setq FH +)
(setq FH -)
)
(setq ent (/ (atof (itoa (fix (fh (* ent (expt 10 n)) 0.5)))) (expt 10 n)))
ent
)
;;; =================================================================
;;; 优化中心线点X坐标
(defun TT-10 (ss xxx / ent ent1 i ptzhongxinx ptzhongxiny ssguol2 x1 x2 y1 y2)
(setq ssguol2 '("ACAD_ISO04W100" "ACAD_ISO08W100"
"CENTER" "CENTER2"
"CENTERX2" "DASHDOT"
"DASHDOT2" "DASHDOTX2"
)
) ; 下面程序将中心线图层加入一个列表
(setq ssguol2 (append
SSguol2
(TT-01 "ACAD_ISO04W100")
(TT-01 "ACAD_ISO08W100")
(TT-01 "CENTER")
(TT-01 "CENTER2")
(TT-01 "CENTERX2")
(TT-01 "DASHDOT")
(TT-01 "DASHDOT2")
(TT-01 "DASHDOTX2")
)
) ; 下面程序将选择集中随层的中心线加入一个列表
(SETQ i 0
PTzhongxinX '()
PTzhongxinY '()
)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (or
(and
(member (cdr (assoc 8 ent1)) ssguol2)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(member (cdr (assoc 6 ent1)) ssguol2)
)
(progn
(setq X1 (car (cdr (assoc 10 ent1)))
Y1 (cadr (cdr (assoc 10 ent1)))
X2 (car (cdr (assoc 11 ent1)))
Y2 (cadr (cdr (assoc 11 ent1)))
)
(if (= Y1 Y2)
(progn
(setq PTzhongxinX (cons (list X1 Y1 0.0) PTzhongxinX))
(setq PTzhongxinX (cons (list X2 Y2 0.0) PTzhongxinX))
)
)
(if (= X1 X2)
(progn
(setq PTzhongxinY (cons (list X1 Y1 0.0) PTzhongxinY))
(setq PTzhongxinY (cons (list X2 Y2 0.0) PTzhongxinY))
)
)
)
)
(SETQ i (+ 1 i))
)
(SETQ i 0)
(while (< i (length PTzhongxinX))
(if (member (nth i PTzhongxinX) xxx)
(SETQ xxx (vl-remove (nth i PTzhongxinX) xxx))
)
(SETQ i (+ 1 i))
)
xxx
)
;;; =================================================================
;;; 优化中心线点Y坐标
(defun TT-11 (ss yyy / ent ent1 i ptzhongxinx ptzhongxiny ssguol2 x1 x2 y1 y2)
(setq ssguol2 '("ACAD_ISO04W100" "ACAD_ISO08W100"
"CENTER" "CENTER2"
"CENTERX2" "DASHDOT"
"DASHDOT2" "DASHDOTX2"
)
) ; 下面程序将中心线图层加入一个列表
(setq ssguol2 (append
SSguol2
(TT-01 "ACAD_ISO04W100")
(TT-01 "ACAD_ISO08W100")
(TT-01 "CENTER")
(TT-01 "CENTER2")
(TT-01 "CENTERX2")
(TT-01 "DASHDOT")
(TT-01 "DASHDOT2")
(TT-01 "DASHDOTX2")
)
) ; 下面程序将选择集中随层的中心线加入一个列表
(SETQ i 0
PTzhongxinX '()
PTzhongxinY '()
)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq ent1 (entget ent))
(if (or
(and
(member (cdr (assoc 8 ent1)) ssguol2)
(/= (cdr (assoc 0 ent1)) "INSERT")
(= (assoc 6 ent1) nil)
)
(member (cdr (assoc 6 ent1)) ssguol2)
)
(progn
(setq X1 (car (cdr (assoc 10 ent1)))
Y1 (cadr (cdr (assoc 10 ent1)))
X2 (car (cdr (assoc 11 ent1)))
Y2 (cadr (cdr (assoc 11 ent1)))
)
(if (= Y1 Y2)
(progn
(setq PTzhongxinX (cons (list X1 Y1 0.0) PTzhongxinX))
(setq PTzhongxinX (cons (list X2 Y2 0.0) PTzhongxinX))
)
)
(if (= X1 X2)
(progn
(setq PTzhongxinY (cons (list Y1 X1 0.0) PTzhongxinY))
(setq PTzhongxinY (cons (list Y2 X2 0.0) PTzhongxinY))
)
)
)
)
(SETQ i (+ 1 i))
)
(SETQ i 0)
(while (< i (length PTzhongxinY))
(if (member (nth i PTzhongxinY) yyy)
(SETQ yyy (vl-remove (nth i PTzhongxinY) yyy))
)
(SETQ i (+ 1 i))
)
yyy
)
| 
发表于 2009-5-29 09:34:00
置顶卡
变色卡
显身卡
发表于 2009-8-10 09:56:00