求助自动将坐标表格放入图中
记得有一个程序点取多段线,可以将多段线顶点坐标表格放入图中,现在找不到,哪位知道请告诉.谢谢! (defun c:zb (/ dcl_id dcl_file result mode)(setq mode "POINTS")
(setq dcl_file (vl-filename-mktemp "zb_dialog.dcl"))
(setq dcl_handle (open dcl_file "w"))
(write-line
"zb_dlg : dialog {
label = \"标注工具\";
: row {
: boxed_radio_column {
label = \"标注模式\";
: radio_button {
label = \"逐点标注\";
key = \"mode_points\";
value = 1;
}
: radio_button {
label = \"多段线顶点标注\";
key = \"mode_poly\";
}
}
}
spacer;
ok_cancel;
}"
dcl_handle
)
(close dcl_handle)
(setq dcl_id (load_dialog dcl_file))
(if (not (new_dialog "zb_dlg" dcl_id))
(exit)
)
(set_tile "mode_points" "1")
(action_tile "mode_points" "(setq mode \"POINTS\")")
(action_tile "mode_poly" "(setq mode \"POLY\")")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq result (start_dialog))
(unload_dialog dcl_id)
(vl-file-delete dcl_file)
(if (= result 1)
(if (= mode "POINTS")
(zb-points)
(zb-polyline)
)
)
(princ)
)
;; 创建表格的通用函数
(defun create-coord-table (pt-list prefix tHt / actDoc mSp vlaTab i row_count)
(vl-load-com)
(setq actDoc (vla-get-ActiveDocument (vlax-get-acad-object))
mSp (vla-get-ModelSpace actDoc)
row_count (length pt-list)
vlaTab (vla-AddTable mSp (vlax-3D-point '(0 0 0)) (+ row_count 1) 3 (* tHt 1.5) (* tHt 20)))
;; 设置表头 - 三个独立的单元格
(vla-SetText vlaTab 0 0 "点号")
(vla-SetText vlaTab 0 1 "Y")
(vla-SetText vlaTab 0 2 "X")
;; 设置表格数据
(setq i 0)
(foreach pt pt-list
(setq i (1+ i))
(vla-SetText vlaTab i 0 (strcat prefix (itoa i)))
(vla-SetText vlaTab i 1 (rtos (cadr pt) 2 3))
(vla-SetText vlaTab i 2 (rtos (car pt) 2 3))
;; 设置单元格样式
(vla-SetCellTextHeight vlaTab i 0 tHt)
(vla-SetCellTextHeight vlaTab i 1 tHt)
(vla-SetCellTextHeight vlaTab i 2 tHt)
(vla-SetCellAlignment vlaTab i 0 acMiddleCenter)
(vla-SetCellAlignment vlaTab i 1 acMiddleCenter)
(vla-SetCellAlignment vlaTab i 2 acMiddleCenter)
)
;; 设置表头样式
(vla-SetCellTextHeight vlaTab 0 0 tHt)
(vla-SetCellTextHeight vlaTab 0 1 tHt)
(vla-SetCellTextHeight vlaTab 0 2 tHt)
(vla-SetCellAlignment vlaTab 0 0 acMiddleCenter)
(vla-SetCellAlignment vlaTab 0 1 acMiddleCenter)
(vla-SetCellAlignment vlaTab 0 2 acMiddleCenter)
;; 设置表格尺寸
(vla-SetColumnWidth vlaTab 0 (* tHt 5))
(vla-SetColumnWidth vlaTab 1 (* tHt 7.5))
(vla-SetColumnWidth vlaTab 2 (* tHt 7.5))
(vla-put-VertCellMargin vlaTab (* tHt 0.35))
(vla-put-Height vlaTab (* (* tHt 1.5) (+ row_count 1)))
;; 移动表格到指定位置
(princ "\n选择表格位置: ")
(command "_.copybase" (trans '(0 0 0) 1 0) (entlast) "")
(command "_.erase" (entlast) "")
(command "_.pasteclip" pause)
vlaTab
)
(defun zb-points (/ pt tHt prefix pt_list)
(vl-load-com)
(setq pt_list '())
(setq tHt (getreal "\n请输入文字高度 (默认值为2.5): "))
(if (not tHt) (setq tHt 2.5))
(setq prefix (getstring T "\n点号前缀: "))
(if (not prefix) (setq prefix ""))
(setq pt (getpoint "\n选择第一个点："))
(while pt
(setq pt_list (cons pt pt_list))
(command "text" "J" "MC" pt tHt 0 (strcat prefix (itoa (length pt_list))))
(command "circle" pt (/ tHt 15))
(setq pt (getpoint "\n选择下一个点："))
)
(if (null pt_list)
(progn
(princ "\n未选择点。")
(exit)
)
)
;; 创建表格
(create-coord-table (reverse pt_list) prefix tHt)
(princ)
)
(defun zb-polyline (/ pl_ent tHt prefix vlaPl coords pt_list i)
(vl-load-com)
(setq tHt (getreal "\n请输入文字高度 (默认值为2.5): "))
(if (not tHt) (setq tHt 2.5))
(setq prefix (getstring T "\n点号前缀: "))
(if (not prefix) (setq prefix ""))
(while (not (setq pl_ent (car (entsel "\n选择多段线: ")))))
(if (not (wcmatch (cdr (assoc 0 (entget pl_ent))) "*POLYLINE"))
(progn
(princ "\n所选对象不是多段线。")
(exit)
)
)
(setq vlaPl (vlax-ename->vla-object pl_ent)
pt_list '()
i 0)
;; 正确获取多段线顶点坐标
(setq coords (vlax-get vlaPl 'Coordinates))
(repeat (/ (length coords) 2)
(setq pt_list (cons (list (nth i coords) (nth (1+ i) coords)) pt_list))
(setq i (+ i 2))
)
(setq pt_list (reverse pt_list))
;; 标注每个顶点
(setq i 0)
(foreach pt pt_list
(setq i (1+ i))
(command "text" "J" "MC" pt tHt 0 (strcat prefix (itoa i)))
(command "circle" pt (/ tHt 15))
)
;; 创建表格
(create-coord-table pt_list prefix tHt)
(princ)
)
(princ "\nZB命令已加载。输入 ZB 开始使用。")
(princ) yaokui25 发表于 2014-7-7 11:12
楼主不好意思
手机上网，地址贴错了
http://bbs.mjtd.com/thread-109223-1-1.html
这个好像就是xy是相反的 xyp1964 发表于 2014-7-6 21:42
对于需要说明控制点坐标的情况很实用 搜索关键字""多段线顶点写入到表格"" http://bbs.mjtd.com/forum.php?mod=viewthread&tid=109223&mobile=yes yaokui25 发表于 2014-7-6 18:23 static/image/common/back.gif
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=109223&mobile=yes
在哪里?找不到.
xyp1964 发表于 2014-7-6 21:42 static/image/common/back.gif
附件不能下载, 本帖最后由 香田里浪人 于 2014-7-9 19:13 编辑
谢谢楼上诸位，电脑里找到了，记不得在哪里下载，程序如下
(defun c:sbzb ()
(setq key 10 i 0 j 0)
(setq obj (car (entsel "\n选择一个多段线: ")))
(setq ent (entget obj))
(setq pt(getpoint"\n坐标表放在："))
(setq x(car pt))
(setq y(cadr pt))
(setq yn y)
(setq x4(- x 10))
(setq pt4(list x4 y))
(setq x1(+ 18 x4))
(setq pt1(list x1 y))
(setq x2(+ 46 x4))
(setq pt2(list x2 y))
(setq y9(+ y 7))
(setq pt9(list x4 y9))
(command "text" pt9 4 0 "多段线顶点坐标")
(command "text" pt4 4 0 "点号")
(command "text" pt1 4 0 "X坐标")
(command "text" pt2 4 0 "Y坐标")
(foreach xy ent
(if (eq (car xy) key )
(progn
(setq j (1+ j))
(setq pe1 (cdr xy))
(command "text" pe1 3 0 j)
(setq yn (- yn 10))
(setq pt3 (list x yn))
(liang pe1 pt3 j )
)
)
)
(setq x5(- x4 3.220))
(setq y5(+ y 5.2259))
(setq pt5(list x5 y5))
(setq x6(+ x5 69.1817))
(setq pt6(list x6 y5))
(command "LINE" pt5 pt6 "")
(setq a(entlast))
(command "array" a "" "r" (+ j 2) 1 -10)
(setq y7(- y5 10))
(setq pt7(list x5 y7))
(command "LINE" pt5 pt7 "")
(setq a(entlast))
(command "array" a "" "r" (+ j 1) 2 -10 11)
(setq pt8(list x6 y7))
(command "LINE" pt6 pt8 "")
(setq a(entlast))
(command "array" a "" "r" (+ j 1) 2 -10 -30)
)
(defun liang(k pt3 r)
(setq xx(car k))
(setq yy(cadr k))
(setq x1(car pt3))
(setq y1(cadr pt3))
(setq x1(+ 28 x1))
(setq pe1(list x1 y1))
(setq xj( - (car pt3) 10))
(setq pe2(list xj y1))
(command "text" pe2 3 0 r)
(command "text" pe1 3 0 (rtos xx 2 3))
(command "text" pt3 3 0 (rtos yy 2 3))
)
院长思路清晰~!~
求函数xyp-List2TableAuto 楼主不好意思
手机上网，地址贴错了
http://bbs.mjtd.com/thread-109223-1-1.html
看看这个 yaokui25 发表于 2014-7-7 11:12 static/image/common/back.gif
楼主不好意思
手机上网，地址贴错了
http://bbs.mjtd.com/thread-109223-1-1.html
你链接的程序2004运行不了。
页:
[1]
2