表格内实体居中-讨论探讨
本帖最后由 尘缘一生 于 2022-8-11 20:04 编辑本坛有不少这方面代码，然而，对其深入写代码起来时候，觉得实在力不从心，总做不到完美，下面贴上两个中间代码。
[*];;表格实体居中------------
[*](defun sl-bjz (/ wt)
[*](setq wt (ssget '((0 . "*TEXT,CIRCLE,ARC,ELLIPSE,DIMENSION,LEADER,INSERT,ATTDEF,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION,SPLINE"))))
[*](ss-bjz wt)
[*])
[*];;wt 表选择集居中 支持所有实体--（一级）----
[*](defun ss-bjz (wt / nam plis plis1 ss n en ent pt0 p0 p01 dis pts tp a b c d)
[*](defun en-bjz (en) ;en 实体居中
[*] (setq ent (entget en) tp (dxf1 en 0))
[*] (setq plis (e-box4 en t) a (car plis) b (cadr plis) c (caddr plis) d (nth 3 plis))
[*] (setq dis (* 0.05 (distance a d)))
[*] (setq p01 (trans (polar (sl:mid d c) (angle a d) dis) 1 0));包容盒外一点
[*] (setq pt0 (sl:mid a c)) ;实体中心
[*] (if (member tp '("ELLIPSE" "CIRCLE"));先删除
[*] (progn
[*] (entdel en)
[*] (ssdel en wt)
[*] )
[*] )
[*] (if (setq nam (sl-bound p01 nil)) ; 边界形成
[*] (progn
[*] (if (member tp '("ELLIPSE" "CIRCLE")) (entmake ent))
[*] (setq plis1 (e-box4 nam t) a (car plis1) c (caddr plis1))
[*] (setq p0 (trans (sl:mid a c) 1 0)) ;单元格中心
[*] (entdel nam)
[*] (setq n (sslength (setq ss (ssget "W" a c))))
[*] (if (> n 0)
[*] (if (= n 1)
[*] (vla-move (en2obj (ssname ss 0)) (vlax-3d-point pt0) (vlax-3d-point p0))
[*] (progn
[*] (setq pts (get-box ss) pt0 (sl:mid (car pts) (cadr pts)))
[*] (command "MOVE" ss "" pt0 p0)
[*] )
[*] )
[*] )
[*] (setq wt (ssdiff wt ss)) ;;差集
[*] )
[*] )
[*])
[*];-----------------------------------
[*](_undo1)
[*](repeat (setq n (sslength wt))
[*] (setq en (ssname wt (setq n (1- n))) tp (dxf1 en 0))
[*] (if (member tp '("ELLIPSE" "CIRCLE")) (en-bjz en))
[*])
[*](repeat (setq n (sslength wt))
[*] (setq en (ssname wt (setq n (1- n))))
[*] (en-bjz en)
[*])
[*](_undo2)
[*])
[*];;三领boundary----(一级)-----
[*];;k 误差值 nil slbl
[*](defun sl-bound (p0 k / e_lst ft en en1 en2 en3)
[*](setq ft
[*] (vl-catch-all-apply
[*] (function
[*] (lambda ()
[*] (setq e_lst (sysvar '("osmode" "cmdecho" "ORTHOMODE" "HPGAPTOL" "HPBOUND" "HPBOUNDRETAIN")))
[*] (setvar "cmdecho" 0)
[*] (setvar "OSMODE" 0)
[*] (setvar "ORTHOMODE" 0)
[*] (setvar "HPBOUND" 1) ;创建多段线 0创建面域
[*] (setvar "HPBOUNDRETAIN" 1) ;根据 HPBOUND 系统变量创建边界对象 0不创建
[*] (if (= k nil) (setq k slbl))
[*] (setvar "HPGAPTOL" k)
[*] (setq en1 (entlast))
[*] (vl-cmdf "-boundary" "a" "o" "p" "" p0 "");生成多段线
[*] (while (> (getvar "cmdactive") 0) (command "n"))
[*] (setq en2 (entlast))
[*] (bpoly p0)
[*] (setq en3 (entlast))
[*] (cond
[*] ((and (equal en2 en1) (equal en3 en1))
[*] (setq en nil)
[*] )
[*] ((and (not (equal en2 en1)) (equal en3 en1))
[*] (setq en en2)
[*] )
[*] ((and (not (equal en3 en1)) (equal en2 en1))
[*] (setq en en3)
[*] )
[*] ((and (not (equal en3 en1))
[*] (not (equal en2 en1))
[*] )
[*] (setq en en2)
[*] (entdel en3)
[*] )
[*] )
[*] )
[*] )
[*] )
[*])
[*](mapcar 'eval e_lst)
[*](if (vl-catch-all-error-p ft) (setq en nil))
[*]en
[*])
以上代码的基础，就是，采用 "-boundary" “poly” 做法，对表格不完全闭合情况，不甚完美
[*];;表格实体居中------------
[*](defun sl-bjz (/ wt en lis)
[*](setq wt (ssget '((0 . "*TEXT,CIRCLE,ARC,ELLIPSE,DIMENSION,LEADER,INSERT,ATTDEF,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION,SPLINE"))))
[*](ss-bjz wt)
[*])
[*];;从一个点求到某个方向最近线的距离---(一级)----
[*](defun snearlin (pt ang / dis ss n obj lst)
[*](if(setq ss (ssget "f" (list pt (polar pt ang (getvar "viewsize"))) '((0 . "LINE,*P*LINE"))))
[*] (progn
[*] (repeat (setq n (sslength ss))
[*] (setqobj (en2obj (ssname ss (setq n (1- n))))
[*] dis (distance pt (vlax-curve-getclosestpointto obj pt t))
[*] lst (cons dis lst)
[*] )
[*] )
[*] (apply 'min lst)
[*] )
[*])
[*])
[*];;实体四周线格包容四角点、实体中点表----（一级）----
[*];;返回 (单元格左下 单元格右下 单元格右上 单元格左上实体中心))
[*](defun enear4p (enam / plis p0 pz py ps px p1 p2 p3 p4)
[*](setq plis (ebox4 enam))
[*](setq p0 (sl:mid (car plis) (caddr plis)))
[*](setq pz (polar p0 pi (snearlin p0 pi))
[*] py (polar p0 0 (snearlin p0 0))
[*] ps (polar p0 pi2 (snearlin p0 pi2))
[*] px (polar p0 3pi2 (snearlin p0 3pi2))
[*] p1 (list (car pz) (cadr px) 0)
[*] p2 (list (car py) (cadr px) 0)
[*] p3 (list (car py) (cadr ps) 0)
[*] p4 (list (car pz) (cadr ps) 0)
[*])
[*](list p1 p2 p3 p4 p0)
[*])
[*];;wt 表选择集居中 支持所有实体--（一级）----
[*](defun ss-bjz (wt / ss n i en pt0 p0 pts a c)
[*](_undo1)
[*](repeat (setq n (sslength wt))
[*] (setq en (ssname wt (setq n (1- n))))
[*] (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (setq pts (enear4p en))))))
[*] (progn
[*] (setq a (car pts) c (caddr pts))
[*] (setq pt0 (nth 4 pts));实体中心
[*] (setq p0 (sl:mid a c)) ;单元格中心
[*] (setq i (sslength (setq ss (ssget "W" a c))))
[*] (if (> i 0)
[*] (progn
[*] (if (= i 1)
[*] (vla-move (en2obj (ssname ss 0)) (vlax-3d-point pt0) (vlax-3d-point p0))
[*] (progn
[*] (setq pts (get-box ss) pt0 (sl:mid (car pts) (cadr pts)))
[*] (command "MOVE" ss "" pt0 p0)
[*] )
[*] )
[*] (setq wt (ssdiff wt ss))
[*] )
[*] )
[*] )
[*] )
[*])
[*](_undo2)
[*])
以上这段代码另辟蹊径，然而，测试发现，也不是太完美。这种方式的缺点就是：表格线不能是连续拐弯方式。
需要说明一点，由于涉及其他，这代码不能独立运行，相信高手们一看就知道函数的作用，本坛也能搜索到。
http://bbs.mjtd.com/thread-181585-1-1.html
这个帖子的跟帖的那个居中还可以 lxl217114 发表于 2022-8-10 14:51
http://bbs.mjtd.com/thread-181585-1-1.html
这个帖子的跟帖的那个居中还可以
我仔细看过这个帖子，贴出来的代码都不行，贴出来的动画是可以的，但是，贴出来动画的，是没有放出源码的。
用我第二种方式，基本达到动画效果了。 尘缘一生 发表于 2022-8-10 16:01
我仔细看过这个帖子，贴出来的代码都不行，贴出来的动画是可以的，但是，贴出来动画的，是没有放出源码的 ...
跟帖的意思是2楼3楼不是楼主的意思。 请问动图中对应的代码是哪一段哦？看着效果已经很完美了。 本帖最后由 尘缘一生 于 2022-8-10 23:19 编辑
20060510412 发表于 2022-8-10 22:45
请问动图中对应的代码是哪一段哦？看着效果已经很完美了。
是第二种方式，又进行了修改，贴上
[*];;表格实体居中------------
[*](defun sl-bjz (/ wt en lis)
[*](setq wt (ssget '((0 . "*TEXT,CIRCLE,ARC,ELLIPSE,DIMENSION,LEADER,INSERT,ATTDEF,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION,SPLINE"))))
[*](ss-bjz wt)
[*])
[*];;从一个点求到某个方向最近线的距离---(一级)----
[*](defun snearlin (pt ang / dis ss n obj lst)
[*](if(setq ss (ssget "f" (list pt (polar pt ang (getvar "viewsize"))) '((0 . "LINE,*P*LINE"))))
[*] (progn
[*] (repeat (setq n (sslength ss))
[*] (setqobj (en2obj (ssname ss (setq n (1- n))))
[*] dis (distance pt (vlax-curve-getclosestpointto obj pt t))
[*] lst (cons dis lst)
[*] )
[*] )
[*] (apply 'min lst)
[*] )
[*])
[*])
[*];;实体四周线框包容四角点、实体中点表----（一级）----
[*];;返回 (单元格左下 单元格右下 单元格右上 单元格左上实体中心))
[*](defun enear4p (enam / plis p0 pz py ps px p1 p2 p3 p4)
[*](setq plis (ebox4 enam))
[*](setq p0 (sl:mid (car plis) (caddr plis)))
[*](setq pz (polar p0 pi (snearlin p0 pi))
[*] py (polar p0 0 (snearlin p0 0))
[*] ps (polar p0 pi2 (snearlin p0 pi2))
[*] px (polar p0 3pi2 (snearlin p0 3pi2))
[*] p1 (list (car pz) (cadr px) 0)
[*] p2 (list (car py) (cadr px) 0)
[*] p3 (list (car py) (cadr ps) 0)
[*] p4 (list (car pz) (cadr ps) 0)
[*])
[*](list p1 p2 p3 p4 p0)
[*])
[*];;wt 表选择集居中 支持所有实体--（一级）----
[*](defun ss-bjz (wt / ss n i en pt0 p0 pts a c dis ang)
[*](_undo1)
[*](repeat (setq n (sslength wt))
[*] (setq en (ssname wt (setq n (1- n))))
[*] (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (setq pts (enear4p en))))))
[*] (progn
[*] (setq a (car pts) c (caddr pts))
[*] (setq pt0 (nth 4 pts));实体中心
[*] (setq p0 (sl:mid a c)) ;单元格中心
[*] (setq dis (* 0.99 (distance a c)) ang (angle a c));;修改此处，对角点进行1%缩小，涉及本行和下面两行
[*] (setq c (polar a ang dis))
[*] (setq a (polar c (+ ang pi) dis))
[*] (setq i (sslength (setq ss (ssget "W" a c))))
[*] (if (> i 0)
[*] (progn
[*] (if (= i 1)
[*] (vla-move (en2obj (ssname ss 0)) (vlax-3d-point pt0) (vlax-3d-point p0))
[*] (progn
[*] (setq pts (get-box ss) pt0 (sl:mid (car pts) (cadr pts)))
[*] (command "MOVE" ss "" pt0 p0)
[*] )
[*] )
[*] (setq wt (ssdiff wt ss))
[*] )
[*] )
[*] )
[*] )
[*])
[*](_undo2)
[*])
那个子函数ebox4，不知道是什么意思，猜不出来…… 尘缘一生 发表于 2022-8-10 23:15
是第二种方式，又进行了修改，贴上
您好，请问您还有highflybird分享的DynamicLisp源代码么？ 20060510412 发表于 2022-9-4 15:04
您好，请问您还有highflybird分享的DynamicLisp源代码么？
你看是不是这个
页:
[1]
2