CAD截图做大样
本帖最后由 masterlong 于 2017-11-28 19:54 编辑要是缺什么子函数的告诉我
;先使用vrec绘制多个矩形
;再使用vjts选择矩形
;;常用变量
(setq
*ent2obj* vlax-Ename->Vla-Object
*obj2ent* vlax-vla-object->ename
*aboutp* vlax-get-Property
;;常用VLA对象、集合
*acadobject* (vlax-get-acad-object)
*acad* (vlax-get-acad-object)
*acaddoc* (vla-get-ActiveDocument *acad*)
*doc* (vla-get-ActiveDocument *acad*)
*alldocs* (vla-get-Documents *acad*)
*MSpace* (vla-get-modelSpace *doc*)
*PSpace* (vla-get-paperSpace *doc*)
*BLKS* (vla-get-Blocks *doc*)
*BLOCKS* (vla-get-Blocks *doc*)
*LAYS* (vla-get-Layers *doc*)
*LAYERS* (vla-get-Layers *doc*)
*Linetypes* (vla-get-Linetypes *doc*)
*TextStyles*(vla-get-TextStyles *doc*)
*groups* (vla-get-groups *doc*)
*DIMS* (vla-get-DimStyles *doc*)
*Layouts* (vla-get-Layouts *doc*)
*Viewports* (vla-get-Viewports *doc*)
*Views* (vla-get-Views *doc*)
*DICS* (vla-get-Dictionaries *doc*)
;;常用的几个外部接口对象
*FSO* (vlax-get-or-create-object "Scripting.FileSystemObject")
*WSH* (vlax-get-or-create-object "wscript.shell")
*SHELL* (vlax-get-or-create-object "Shell.Application")
*SCR* (vlax-get-or-create-object "ScriptControl")
*WBEM*(vlax-get-or-create-object "WbemScripting.SWbemLocator")
)
;;建立下一程序所需要的文件夹、图层，并绘制矩形
(defun c:vrec()
(vl-mkdir "c:\\qgy_temp")
(vl-mkdir "c:\\qgy_temp\\布局转模型")
(setvar "ctab" "model")
(command "layer""m" "z__其它" "c" "240" "" "m" "zzz___图框内框线" "c" "30" "" "P" "N" "" "")
(command "rectang" pause pause)
)
;;选择指定图层中的矩形，分别指定每个矩形的大样放置位置，借用高版CAD的布局转模型命令，在模型中生成大样。（速度会有点慢，但不是死机）【需要express工具支持】
(defun c:vjts()
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(if (and
(setvar "ctab" "model")
(setq recss (ssget '((0 . "LWPOLYLINE")(8 . "zzz___图框内框线")(90 . 4)(70 . 1))))
(setq pppooo (car (ssbox recss)))
)
(progn
(command "undo" "g")
(setq oflist '())
(foreach x (setq reclist (ss2list recss))
(zooment x 8)
(setq xbox (entbox x))
(setq p1 (car xbox)
p2 (cadr xbox)
p12 (list (car p1) (cadr p2))
)
(setq ss (ssadd x))
(setq p3 (acet-ss-drag-move ss p1 T 0)) ;;【如果没有安装express工具】 将此句改为 (setq p3 (getpoint p1 "\n指定空白处1点 : "))
(if (or
(and (< (car p1) (car p3)) (> (cadr p1) (cadr p3)))
(and (> (car p1) (car p3)) (< (cadr p1) (cadr p3)))
)
(command "line" "non" p1 "non" p3 "" "change" (entlast) "" "p" "la" "z__其它" "co" 240 "lt" "byl" "")
(command "line" "non" p1 "non" p3 "" "move" (entlast) "" "non" p1 "non" p12 "change" (entlast) "" "p" "la" "z__其它" "co" 240 "lt" "byl" "")
)
(setq oflist (cons (list x p3) oflist))
)
(setq oflist (reverse oflist))
(setq 时间 (getvar "cdate"))
(setq 时间 (rtos 时间 2 6))
(setq 标记时间 (strcat (substr 时间 1 4) "年" (substr 时间 5 2) "月" (substr 时间 7 2) "日" (substr 时间 10 2) "时" (substr 时间 12 2) "分") )
(setq 组合块名 (strcat "临时布局___" 标记时间 (substr 时间 14)))
(setq thevpname 组合块名)
(setq vpp_vplot (vla-add *Layouts* thevpname))
(setvar "ctab" thevpname)
(foreach xpppp oflist
(setq x (car xpppp)
p3 (cadr xpppp)
)
(setq box (entbox x))
(setq p1 (car box)
p2 (cadr box)
)
(setq vvvp1 p3
vvvp2 (ptwy (ptwy p3 (- (car p2) (car p1)) 0) 0 (- (cadr p2)(cadr p1)))
)
(command "_mview" "non" vvvp1 "non" vvvp2)
(setq vdfx69 (cdr (assoc 69 (entget (entlast)))))
(command "PSPACE" "zoom" "w" "non" vvvp1 "non" vvvp2)
(command "_mspace")
(setvar "cvport" vdfx69)
(command "zoom" "w" "non" p1 "non" p2)
(command "_mview" "l" "on" "l" "")
(command "PSPACE")
)
(command "PSPACE" "zoom" "e")
(command "EXPORTLAYOUT" (strcat "c:\\qgy_temp\\布局转模型\\" thevpname ".dwg"))
(setvar "ctab" "model")
(vlax-invoke-method vpp_vplot 'Delete)
(command "insert" (strcat "c:\\qgy_temp\\布局转模型\\" thevpname ".dwg") "non" '(0 0) 1 1 0)
(command "undo" "e")
)
)
(princ)
)
;999以指定图元缩放窗口
(defun zooment( ent sc / box x midpo ) ;;(setq paper (cdr (assoc 410 (entget ent)))) (~~ paper) (setvar "ctab" paper)
(setq box (entbox ent))
;;(setq box (mapcar 'u2w box))
(setq midpo (getmidpo box))
(setq box (mapcar '(lambda (x) (p0_sc_p1 midpo x sc)) box))
(vla-zoomwindow *acad* (vlax-3d-point (car box)) (vlax-3d-point (cadr box)))
box
)
;;单个物体的最小（正交）包围框---------------------------------这个程序在遇到无法显示的图元时，还是会出错的，比如形。天正图元会不会也不支持，未测试
(defun entbox ( ent / ll ur )
(vla-getboundingbox (*ent2obj* ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;;选择集转为图元列表
(defun ss2list ( ss / n i elist )
(setq n (if (= (type ss) 'Pickset) (sslength ss) 0)
i n
elist '()
)
(repeat n
(setq elist (cons (ssname ss (setq i (1- i))) elist))
)
)
;;选择集的最小（正交）包围框
(defun ssbox( ss / ll ur aa bb )
(if (= (type ss) 'PICKSET)
(setq ss (ss2list ss))
)
(foreach x ss
(vla-getboundingbox (*ent2obj* x) 'll 'ur)
(setq aa (cons (vlax-safearray->list ll) aa)
bb (cons (vlax-safearray->list ur) bb)
)
)
(mapcar '(lambda(a b) (apply 'mapcar (cons a b)))
'(min max)
(list aa bb)
)
)
;;ptwy点坐标位移
(defun ptwy( pt x y )
(polar (polar pt 0 x) (setq d_090(* 0.5 pi)) y)
)
与选择集有关的函数
在执行前都应该先检验参数是否选择集
楼上的函数可以这样改
(if (= (type ss) 'Pickset)(mapcar 'cadr (ssnamex ss)))
___
命令:VJTS
选择对象：找到 1 个
选择对象： undo
当前设置: 自动 = 开，控制 = 全部，合并 = 是，图层 = 是
输入要放弃的操作数目或 [自动(A)/控制(C)/开始(BE)/结束(E)/标记(M)/后退(B)] <1>:g
指定空白处1点 :
指定空白处1点 : line
指定第一点: non
指定下一点或 [角度(A)/长度(L)/放弃(U)]: non
指定下一点或 [角度(A)/长度(L)/放弃(U)]:
move
选择对象：找到 1 个
选择对象：
指定基点或 [位移(D)] <位移>:non指定第二个点或 <使用第一个点作为位移>: nonchange
选择对象：找到 1 个
选择对象：
指定修改点或 [特性(P)]: p
输入要更改的特性 [颜色(C)/标高(E)/图层(LA)/线型(LT)/线型比例(S)/线宽(LW)/厚度(T)/透明度(TR)/材质(M)/注释性(A)]:
la
输入新图层名 <zzz___图框内框线>: z__其它
输入要更改的特性 [颜色(C)/标高(E)/图层(LA)/线型(LT)/线型比例(S)/线宽(LW)/厚度(T)/透明度(TR)/材质(M)/注释性(A)]:
co
新颜色 [真彩色(T)/配色系统(CO)] <ByLayer>:
输入要更改的特性 [颜色(C)/标高(E)/图层(LA)/线型(LT)/线型比例(S)/线宽(LW)/厚度(T)/透明度(TR)/材质(M)/注释性(A)]:
lt
输入新线型名 <CONTINUOUS>: byl
线型“byl”未找到。请用 LINETYPE 命令来加载。
输入要更改的特性 [颜色(C)/标高(E)/图层(LA)/线型(LT)/线型比例(S)/线宽(LW)/厚度(T)/透明度(TR)/材质(M)/注释性(A)]:
; 错误:
函数被取消
输入要更改的特性 [颜色(C)/标高(E)/图层(LA)/线型(LT)/线型比例(S)/线宽(LW)/厚度(T)/透明度(TR)/材质(M)/注释性(A)]:
*取消*
_____
还是报错，楼主在不在，帮帮忙啊。。
本帖最后由 masterlong 于 2017-11-30 09:42 编辑
;;求点对中点
(defun getmidpo( pts / P1 P2 X Y )
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
nil
(setq p1 (list (car p1) (cadr p1))
p2 (list (car p2) (cadr p2))
)
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)
“/”在使用时
要注意除数是整数还是小数
另外p1、p2格式不同是容易被忽视的
感谢大师分享程序! 缺这个函数，其它的能靠名字猜：
ptwy ;;ptwy点坐标位移
(defun ptwy( pt x y )
(polar (polar pt 0 x) d_090 y)
) (setq d_090(* 0.5 pi)) no function definition: *ENT2OBJ*
出现这个，啥问题？ 学习一下。谢谢:victory: EXPORTLAYOUT不支持天正建筑图，有办法不用这个命令吗？ 不喜欢做成块，G版的局部放大做成xclip也是无奈之举啊。 不是建筑专业对天正不熟悉
个人习惯要求建筑提资转t3
需要画大样的时候
一般都是用这个程序来截图
其实高版cad的剪切功能比低版功能要强
直接框外剪切也可以
无非是操作麻烦一点而已