（悬赏50币）求修改langjs大师的《相同刷》刷图块不改变被刷图块的的方向！！！
本帖最后由 lingduwx 于 2013-7-27 14:46 编辑悬赏币，我另外开贴领取（实在不好意思），偶实在是弄不来，求各位高手帮帮忙吧，小弟先谢了
真心希望langjs大师的《相同刷》刷图块时保持被刷图块的的方向，谢谢！！！
经常做好的图图块已经被旋转了方向，需要刷部分块，所以希望刷块之后，图块保持和被刷之前的方向。
例如下图：
都公开源程序了，只需要改一下变量就行了，自己动手试试 俺实在是不会啊，麻烦高手帮忙改一个嘛
谢谢！！！ pzweng 发表于 2013-7-26 22:39 static/image/common/back.gif
都公开源程序了，只需要改一下变量就行了，自己动手试试
俺实在是不会啊，麻烦高手帮忙改一个嘛，真的很需要
谢谢！！！ 麻烦高手们些帮忙改一下嘛，小弟确实搞不懂啊，先谢谢了！！！ (defun c:xts (/ #errxts $orr buk en1 ent i name name1 snap ss tp ty uu)
(defun #errxts (s) ; 出错处理程序
(redraw name 4)
(setvar "nomutt" 0)
(setvar "PICKBOX" buk)
(setvar "osmode" snap)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
(setq $orr *error*)
(setq *error* #errxts)
(vl-load-com) ; 主程序开始
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq snap (getvar "osmode"))
(setvar "osmode" 0)
(setq buk (getvar "PICKBOX"))
(setvar "PEDITACCEPT" 1) ; 下面程序选择合适的源对象，如没选到重新选
(while (not (and
(setq name1 (nentsel "\n选择源对象:"))
(setq name (car name1))
(setq ent (entget name))
(setq ty (cdr (assoc 0 ent)))
(member ty '("TEXT" "MTEXT"
"LWPOLYLINE" "CIRCLE"
"INSERT" "LINE"
"ARC" "HATCH"
"DIMENSION" "ATTRIB"
"TCH_ARROW" "TCH_TEXT"
"TCH_DRAWINGNAME" "TCH_MULTILEADER"
"TCH_ELEVATION"
)
)
)
)
(if (= 52 (getvar "errno"))
(vl-exit-with-error "")
)
) ; 下面程序加了一个判断，如果源对象选择的是块，且不是属性或者块内文字，则认为选择的是块
(if (and
(not (member ty '("TEXT" "MTEXT"
"ATTRIB"
)
)
)
(= (type (car (last name1))) 'ename)
(= (cdr (assoc 0 (entget (car (last name1))))) "INSERT")
)
(setq name (car (last name1))
ent (entget name)
ty (cdr (assoc 0 ent))
)
)
(redraw name 3)
(setvar "nomutt" 1)
(setvar "PICKBOX" (fix (+ 1 (* 1.2 buk))))
(cond ; 1、 如果源对象是文字、天正文字或者块内文字或者属性，则执行。。。
((member ty '("TEXT" "MTEXT"
"ATTRIB" "TCH_TEXT"
"TCH_ARROW" "TCH_DRAWINGNAME"
"TCH_MULTILEADER" "TCH_ELEVATION"
)
)
(setq uu (cdr (assoc 1 ent)))
(princ (strcat "\n选择目标对象:<文字相同>T = " "\"" uu "\""))
(while t
(setq ss (ssget ":S" '((0 . "TEXT,MTEXT,INSERT,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION"))))
(if (= (caar (setq name1 (ssnamex ss 0))) 1) ; 如果目标文字是单选块内文字或者属性或普通文字，则执行。。。
(progn
(setq ent (ssname ss 0)
en1 (car (nentselp (trans (cadr (last (car name1))) 0 1)))
tp (cdr (assoc 0 (entget en1)))
)
(cond
((member tp '("TEXT" "MTEXT"
"ATTRIB"
)
)
(vla-put-textstring (vlax-ename->vla-object en1) uu)
(entupd en1)
(entupd ent)
)
((member tp '("TCH_TEXT" "TCH_ELEVATION"
"TCH_ARROW"
)
)
(vlax-put-property (vlax-ename->vla-object en1) 'text uu)
)
((= tp "TCH_DRAWINGNAME")
(vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
)
((= tp "TCH_MULTILEADER")
(vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
)
)
)
(progn ; 如果目标文字多选的是普通文字，则循环更新文字内容
(repeat (setq i (sslength ss))
(setq ent (entget (setq en1 (ssname ss (setq i (1- i))))))
(setq tp (cdr (assoc 0 ent)))
(cond
((member tp '("TEXT" "MTEXT"))
(entmod (subst
(cons 1 uu)
(assoc 1 ent)
ent
)
)
)
((member tp '("TCH_TEXT" "TCH_ELEVATION"
"TCH_ARROW"
)
)
(vlax-put-property (vlax-ename->vla-object en1) 'text uu)
)
((= tp "TCH_DRAWINGNAME")
(vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
)
((= tp "TCH_MULTILEADER")
(vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
)
)
)
)
)
)
)
((member ty '("CIRCLE" "ARC")) ; 3、 如果源对象是圆，则循环更新目标圆的直径
(setq uu (cdr (assoc 40 ent)))
(princ (strcat "\n选择目标对象:<半径相同>R = " (rtos uu 2 2)))
(repeat (setq i (sslength (setq ss (ssget '((0 . "CIRCLE,ARC"))))))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
(cons 40 uu)
(assoc 40 ent)
ent
)
)
)
)
((= ty "INSERT") ; 4、 如果源对象是块，则拷贝源块到目标块的位置，删除目标块
(princ " \n选择目标对象:<块相同>")
(setq uu (cdr (assoc 10 ent)))
(repeat (setq i (sslength (setq ss (ssget '((0 . "INSERT"))))))
(setq ent (entget (ssname ss (setq i (1- i)))))
(setq ent_ang (cdr (assoc 50 ent)))
;;; (setq ent_sc (cdr (assoc 41 ent)))
;;; (command ".insert" (cdr (assoc 2 ent))(cdr (assoc 10 ent)) (cdr (assoc 41 ent)) (cdr (assoc 42 ent)) (cdr (assoc 43 ent)) (/ (* 180 (cdr (assoc 50 ent))) pi))
(command "COPY" name "" uu (cdr (assoc 10 ent)))
(setq new_insert (entlast))
(setq new_dat (entget new_insert))
(entmod (subst (cons 50 ent_ang) (assoc 50 new_dat)new_dat))
)
(command "ERASE" ss "")
)
((= ty "LWPOLYLINE") ; 5、 如果源对象是多义线，则转化目标对象的线宽
(if (not (setq uu (cdr (assoc 43 ent))))
(setq uu (cdr (assoc 40 ent)))
)
(princ (strcat "\n选择目标对象:<线宽相同> W = " (rtos uu 2 2)))
(repeat (setq i (sslength (setq ss (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))))
(setq name1 (ssname ss (setq i (1- i)))
tp (cdr (assoc 0 (setq ent (entget name1))))
)
(cond
((member tp '("LINE" "ARC"))
(command "pedit" name1 "w" uu "x")
)
((member tp '("POLYLINE" "LWPOLYLINE"))
(command "pedit" name1 "w" uu "x")
)
((= tp "CIRCLE")
(command "donut" (- (* (cdr (assoc 40 ent)) 2) uu) (+ (* (cdr (assoc 40 ent)) 2) uu) (cdr (assoc 10 ent)) "")
(entdel name1)
)
)
)
) ; 6、其他的一些情况，则调用特性匹配命令
((member ty '("LINE" "HATCH"
"DIMENSION"
)
)
(princ "\n选择目标对象:<特性匹配>")
(command "matchprop" name (ssget (list (cons 0 ty))) "")
)
)
(redraw name 4)
(setvar "nomutt" 0)
(setvar "PICKBOX" buk)
(setvar "osmode" snap)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
) pzweng 发表于 2013-7-27 19:58 static/image/common/back.gif
(defun c:xts (/ #errxts $orr buk en1 ent i name name1 snap ss tp ty uu)
(defun #errxts (s) ...
非常感谢版主的热心关注，现在终于可以不改变被刷块的方向了。
1、不过“增强属性块”的文字的方向同被刷块方向一致就更好了，例如下图：
2、输入命令显示如下（可否麻烦版主弄成简体中文，这个确实有点看不懂啊）：
命令: xts
閫夋嫨婧愬黡?
閫夋嫨鐩爣瀵硅薄:<鍧楃浉鍚
3、另 请教下我保存为最后一种格式不知道是否正确，主要是前面几种格式我加载都出现错误啊
麻烦版主再修改一下嘛，谢谢了！！！ 如果想用这个程序来改的话还不如重新写一个，改这个的工作量太大了 电气专业的吗
页:
[1]