对象对齐程序，求高手完善。
本帖最后由 hnlgy 于 2013-6-10 16:25 编辑日常工作中经常需要将一些图形对象对齐，而Autocad缺没有提供这样的工具，在论坛里一番搜索之后发现明总的一个小程序比较适合自己，可惜的是只有水平方向对齐，没有垂直方向对齐的功能，（明总有一个VBA的程序是支持的，但我一直无法运行,工作环境win764位、AutoCad2008 32位+天河PCCAD2011），自己折腾了半天也没搞明白.请论坛里的高手们出手完善，谢谢！
;;对象对齐程序
;;原作者 明经论坛郑立楷
(defun c:WQHL ()
(Princ "将所选对象按指定坐标靠左水平对齐")
(setq DQfx "HL")
(process DQfx)
(princ)
)
(defun c:WQHM ()
(Princ "将所选对象按指定坐标居中水平对齐")
(setq DQfx "HM")
(process DQfx)
(princ)
)
(defun c:WQHR ()
(Princ "将所选对象按指定坐标靠右水平对齐")
(setq DQfx "HR")
(process DQfx)
(princ)
)
(defun c:WQVT ()
(Princ "将所选对象按指定坐标靠上垂直对齐")
(setq DQfx "VT")
(process DQfx)
(princ)
)
(defun c:WQVM ()
(Princ "将所选对象按指定坐标居中垂直对齐")
(setq DQfx "VM")
(process DQfx)
(princ)
)
(defun c:WQVD ()
(Princ "将所选对象按指定坐标靠下垂直对齐")
(setq DQfx "VD")
(process DQfx)
(princ)
)
(defun process (amode / apnt apnt_x apnt_y
count objname vlaxobj MinPoint MaxPoint
minext maxext ext_l ext_r ext_m
tpnt
)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq selobjs (ssget))
(if (or (not selobjs) (= (sslength selobjs) 1))
(princ "\n你必须选定两个或两个以上的对象")
)
(initget 1)
(setq apnt (getpoint "\n选择对齐点："))
(setq apnt_x (car apnt)
apnt_y (cadr apnt)
)
(vl-load-com)
(setq count 0)
(repeat (sslength selobjs)
(setq objname (ssname selobjs count))
(setq vlaxobj (vlax-ename->vla-object objname))
(setq MinPoint (vlax-make-variant))
(setq MaxPoint (vlax-make-variant))
(vla-GetBoundingBox vlaxobj 'MinPoint 'MaxPoint)
(setq minext (vlax-safearray->list MinPoint))
(setq maxext (vlax-safearray->list MaxPoint))
(setq ext_l (car minext))
(setq ext_r (car maxext))
(setq ext_m (+ (/ (abs (- ext_l ext_r)) 2) ext_l))
(cond
((= amode "HL")
(setq tpnt (list ext_l apnt_y))
)
((= amode "HM")
(setq tpnt (list ext_m apnt_y))
)
((= amode "HR")
(setq tpnt (list ext_r apnt_y))
)
((= amode "VT")
;;(setq tpnt (list ext_l apnt_y))
)
((= amode "VM")
;;(setq tpnt (list ext_m apnt_y))
)
((= amode "VD")
;;(setq tpnt (list ext_r apnt_y))
)
)
(if tpnt
(command "_move" objname "" "non" tpnt "non" apnt)
)
(setq count (1+ count))
)
(setvar "cmdecho" oldcmdecho)
)
明经论坛上有相关插件，我奉献一个小萝卜头的早期作品，谢谢原作者，
本帖最后由 hnlgy 于 2013-6-10 21:59 编辑
感谢楼上的回复，不过不是我所需要的工具。我的设想是做个像VBA窗体设计工具栏一样的形式，做出左对齐、右对齐、居中对齐，顶端对齐，中间对齐，底端对齐六个按钮分别调用WQHL (),WQHM()................
工具栏已经做好了。
好耍，，，， 本帖最后由 ZZXXQQ 于 2013-6-11 23:16 编辑
;主函数改了下，加上了对话框。
(defun process (amode / apnt apnt_x apnt_y count objname vlaxobj MinPoint MaxPoint
minext maxext ext_l ext_r ext_m ext_vt ext_vd ext_vm tpnt)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq selobjs (ssget))
(if (or (not selobjs) (= (sslength selobjs) 1))
(princ "\n你必须选定两个或两个以上的对象")
)
(initget 1)
(setq apnt (getpoint "\n选择对齐点："))
(setq apnt_x (car apnt)
apnt_y (cadr apnt))
(vl-load-com)
(setq count 0)
(repeat (sslength selobjs)
(setq objname (ssname selobjs count))
(setq vlaxobj (vlax-ename->vla-object objname))
(setq MinPoint (vlax-make-variant))
(setq MaxPoint (vlax-make-variant))
(vla-GetBoundingBox vlaxobj 'MinPoint 'MaxPoint)
(setq minext (vlax-safearray->list MinPoint))
(setq maxext (vlax-safearray->list MaxPoint))
(setq ext_l (car minext))
(setq ext_r (car maxext))
(setq ext_m (+ (/ (abs (- ext_l ext_r)) 2) ext_l))
(setq ext_vd (cadr minext))
(setq ext_vt (cadr maxext))
(setq ext_vm (+ (/ (abs (- ext_vt ext_vd)) 2) ext_vd))
(cond
((= amode "HL") (setq tpnt (list ext_l apnt_y)))
((= amode "HM") (setq tpnt (list ext_m apnt_y)))
((= amode "HR") (setq tpnt (list ext_r apnt_y)))
((= amode "VT") (setq tpnt (list apnt_x ext_vt)))
((= amode "VM") (setq tpnt (list apnt_x ext_vm)))
((= amode "VD") (setq tpnt (list apnt_x ext_vd)))
)
(if tpnt (command "_move" objname "" "non" tpnt "non" apnt))
(setq count (1+ count))
)
(setvar "cmdecho" oldcmdecho)
)
(defun c:dq ()
(setq fp (open "dq.dcl" "w"))
(foreach x
'("dq:dialog{\n"
" label=\"对齐物体 2013\";\n"
" :row{\n"
":button{label=\" 左对齐 \";key=\"hl\";allow_accept=true;}\n"
":button{label=\"水平居中\";key=\"hm\";allow_accept=true;}\n"
":button{label=\" 右对齐 \";key=\"hr\";allow_accept=true;}\n"
" }\n"
" :row{\n"
":button{label=\" 上对齐 \";key=\"vt\";allow_accept=true;}\n"
":button{label=\"垂直居中\";key=\"vm\";allow_accept=true;}\n"
":button{label=\" 下对齐 \";key=\"vd\";allow_accept=true;}\n"
" }\n"
" cancel_button;\n"
"}\n"
)
(princ x fp)
)
(close fp)
(if (> (setq dcl_id (load_dialog (findfile "dq.dcl"))) 0) (progn
(if (new_dialog "dq" dcl_id "") (progn
(action_tile "hl" "(done_dialog 1)")
(action_tile "hm" "(done_dialog 2)")
(action_tile "hr" "(done_dialog 3)")
(action_tile "vt" "(done_dialog 4)")
(action_tile "vm" "(done_dialog 5)")
(action_tile "vd" "(done_dialog 6)")
(action_tile "cancel" "(done_dialog 0)")
(setq re (start_dialog))
)
(princ "\n无法显示对话框！")
)
(unload_dialog dcl_id)
)
(princ "\n无法加载对话框！")
)
(cond
((= re 1) (process "HL"))
((= re 2) (process "HM"))
((= re 3) (process "HR"))
((= re 4) (process "VT"))
((= re 5) (process "VM"))
((= re 6) (process "VD"))
)
(princ)
)
感谢ZZXXQQ 版主出手，经测试可用。唯一的缺陷是正好把顶端对齐与底端对齐效果弄反了。
((= amode "VT") (setq tpnt (list apnt_x ext_vl)))
((= amode "VM") (setq tpnt (list apnt_x ext_vm)))
((= amode "VD") (setq tpnt (list apnt_x ext_vr)))
这三句换成下面的
((= amode "VD") (setq tpnt (list apnt_x ext_vl)))
((= amode "VM") (setq tpnt (list apnt_x ext_vm)))
((= amode "VT") (setq tpnt (list apnt_x ext_vr)))
就正是我所需要的效果。
5楼改了，再试试。 本帖最后由 龙城飞将36 于 2013-6-11 18:59 编辑
错误: 参数类型错误: numberp: nil
((= amode "HL") (setq tpnt (list ext_l apnt_y)))tpnt为nil 关了，重试正常了~~~~~~~~~~~~~~~~~~~~~~~~~~~~··· ZZXXQQ 发表于 2013-6-11 16:44 static/image/common/back.gif
;主函数改了下，加上了对话框。
z版粽子节快乐哈