求两个LiSP小程序，一个是加编号的，一个是加边框的
加边框的能达到图片的效果就行了，加编号的，不要像图片那样非得选择实体的东西，我需要的就是输入命令后直接用鼠标到处去点就能够出来编号了的！谢谢大家了 ;;加边框(Defun c:tt(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
RightDis UpDis selecollection index ptlist VlaObject maxpoint minpoint
pt1 pt2 pt3 pt4 polylinept polypt )
(vl-load-com)
(setq*AcadObject* (vlax-get-acad-object)
*DwgObject*(vla-get-activedocument *AcadObject*)
*ModelSpace* (vla-get-modelspace *DwgObject*)
*Layers* (vla-get-layers *DwgObject*)
*Blocks* (vla-get-blocks *DwgObject*)
*LineTypes*(vla-get-linetypes *DwgObject*)
)
(if (not RightDis_1)(setq RightDis_1 10.0))
(setq RightDis(getreal (strcat"\n请输入左右偏移距离:<"(rtos RightDis_1)">")))
(if RightDis(setq RightDis_1 RightDis)(setq RightDis RightDis_1))
(if (not UpDis_1)(setq UpDis_1 10.0))
(setq (getreal (strcat"\n请输上下偏移距离:<"(rtos UpDis_1)">")))
(if UpDis(setq UpDis_1 UpDis)(setq UpDis UpDis_1))
(setq selecollection(ssget))
(while selecollection
(setq index 0 ptlist nil)
(repeat (sslength selecollection)
(setq VlaObject(vlax-ename->vla-object(ssname selecollection index)))
(vlax-invoke-method VlaObject 'GetBoundingBox 'minpoint 'maxpoint)
(setq maxpoint(vlax-safearray->list maxpoint))
(setq minpoint(vlax-safearray->list minpoint))
(setq ptlist(append ptlist(list maxpoint minpoint)))
(setq index(1+ index))
)
(setq MinPoint(apply 'mapcar (cons 'min ptlist)))
(setq MaxPoint(apply 'mapcar (cons 'max ptlist)))
(setq pt1(list(-(car MinPoint)RightDis)(-(cadr MinPoint)UpDis)0))
(setq pt3(list(+(car maxpoint)RightDis)(+(cadr maxpoint)UpDis)0))
(setq pt2(list(car pt3)(cadr pt1)0))
(Setq pt4(list(car pt1)(cadr pt3)0))
(setq polylinept(append pt1 pt2 pt3 pt4 pt1))
(setq polypt(vlax-make-safearray vlax-vbDouble '(0 . 14)))
(vlax-safearray-fill polyptpolylinept)
(vlax-invoke-method *modelspace* 'addpolyline polypt)
(setq selecollection(ssget))
)
(prin1)
)
;;加边框
;;design:guowei
;;2014/07/03
(Defun c:tt(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
RightDis UpDis selecollection index ptlist VlaObject maxpoint minpoint
pt1 pt2 pt3 pt4 polylinept polypt )
(vl-load-com)
(setq*AcadObject* (vlax-get-acad-object)
*DwgObject*(vla-get-activedocument *AcadObject*)
*ModelSpace* (vla-get-modelspace *DwgObject*)
*Layers* (vla-get-layers *DwgObject*)
*Blocks* (vla-get-blocks *DwgObject*)
*LineTypes*(vla-get-linetypes *DwgObject*)
)
(if (not RightDis_1)(setq RightDis_1 10.0))
(setq RightDis(getreal (strcat"\n请输入左右偏移距离:<"(rtos RightDis_1)">")))
(if RightDis(setq RightDis_1 RightDis)(setq RightDis RightDis_1))
(if (not UpDis_1)(setq UpDis_1 10.0))
(setq UpDis(getreal (strcat"\n请输上下偏移距离:<"(rtos UpDis_1)">")))
(if UpDis(setq UpDis_1 UpDis)(setq UpDis UpDis_1))
(setq selecollection(ssget))
(while selecollection
(setq index 0 ptlist nil)
(repeat (sslength selecollection)
(setq VlaObject(vlax-ename->vla-object(ssname selecollection index)))
(vlax-invoke-method VlaObject 'GetBoundingBox 'minpoint 'maxpoint)
(setq maxpoint(vlax-safearray->list maxpoint))
(setq minpoint(vlax-safearray->list minpoint))
(setq ptlist(append ptlist(list maxpoint minpoint)))
(setq index(1+ index))
)
(setq MinPoint(apply 'mapcar (cons 'min ptlist)))
(setq MaxPoint(apply 'mapcar (cons 'max ptlist)))
(setq pt1(list(-(car MinPoint)RightDis)(-(cadr MinPoint)UpDis)0))
(setq pt3(list(+(car maxpoint)RightDis)(+(cadr maxpoint)UpDis)0))
(setq pt2(list(car pt3)(cadr pt1)0))
(Setq pt4(list(car pt1)(cadr pt3)0))
(setq polylinept(append pt1 pt2 pt3 pt4 pt1))
(setq polypt(vlax-make-safearray vlax-vbDouble '(0 . 14)))
(vlax-safearray-fill polyptpolylinept)
(vlax-invoke-method *modelspace* 'addpolyline polypt)
(setq selecollection(ssget))
)
(prin1)
)
;;加编号
;;desing:guowei
;;2014/07/03
(DEFUN C:EE(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
TxtHeight txt index InsertPoint TextString)
(vl-load-com)
(setq*AcadObject* (vlax-get-acad-object)
*DwgObject*(vla-get-activedocument *AcadObject*)
*ModelSpace* (vla-get-modelspace *DwgObject*)
*Layers* (vla-get-layers *DwgObject*)
*Blocks* (vla-get-blocks *DwgObject*)
*LineTypes*(vla-get-linetypes *DwgObject*)
)
(setq TxtHeight(getvar "dimtxt"))
(if(not txt_1)(setq txt_1 "荣鑫刀模hg140301-"))
(setq txt(getstring (strcat"\n请输入前辍:<"txt_1">")))
(if(or(= txt "")(= txt nil))(setq txt txt_1)(setq txt_1 txt))
(if(not index_1)(setq index_1 1))
(setq index(getint (strcat "\n请输入序号:<"(rtos index_1 2 0)">")))
(if index(setq index_1 index)(setq index index_1))
(while(setq InsertPoint(trans(getpoint "\n输入序号插入点:")1 0))
(setq TextString(strcat txt(rtos index 2 0)))
(vlax-invoke-method *ModelSpace* 'addtext TextString(vlax-3d-point InsertPoint) TxtHeight)
(setq index_1(setq index(1+ index)))
)
(prin1)
)
;; 加边框，需要e派工具箱(XCAD)的支持
(defun c:tt ()
(setq dd (Udist 1 "" "边框宽度<输入或鼠标直接量取>" dd nil))
(while (setq ss (ssget))
(setq p1 (xyp-Pt2XY (xyp-9pt ss 1) (- dd) (- dd))
p9 (xyp-Pt2XY (xyp-9pt ss 9) dd dd)
s1 (xyp-rectang p1 p9)
)
)
(princ)
) ;尾号递增
(defun c:tt ()
(setvar "CMDECHO" 0)
(vl-load-com)
(setq n 1)
(setq str (if (= (type str) 'STR) str ""))
(setq str (getstring (strcat "\n文字前缀" str ": ")))
(while (setq pt (getpoint "\n封闭区域内一点: "))
(setq s1 (entlast) ss(ssadd))
(command "boundary" pt "")
(while (setq s1 (entnext s1)) (ssadd s1 ss))
(if (> (sslength ss) 0) (progn
(setq i -1 plst (list))
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)
(setq plst (append plst (list(vlax-safearray->list p1)(vlax-safearray->list p2))))
)
(command "_.ERASE" ss "")
(setq p1 (apply 'mapcar (cons 'min plst)))
(setq p2 (apply 'mapcar (cons 'max plst)))
; (setq p1 (list (apply 'min (mapcar 'car plst)) (apply 'min (mapcar 'cadr plst))))
; (setq p2 (list (apply 'max (mapcar 'car plst)) (apply 'max (mapcar 'cadr plst))))
(setq pm (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2))
(command "_.TEXT" "M" pm 300 "" (strcat str (itoa n)))
(setq n (1+ n))
))
)
(setvar "CMDECHO" 1)
(princ)
)
;;加边框
(defun c:ttt ()
(setvar "CMDECHO" 0)
(vl-load-com)
(setq bx (getdist "\nEnter Around Space 输入四周间隔: "))
(while (progn (princ "\n选择加框物体: ") (setq ss (ssget)))
(setq i -1 plst (list))
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)
(setq plst (append plst (list(vlax-safearray->list p1)(vlax-safearray->list p2))))
)
(setq p1 (apply 'mapcar (cons 'min plst)))
(setq p2 (apply 'mapcar (cons 'max plst)))
(setq p1 (mapcar '- p1 (list bx bx)))
(setq p2 (mapcar '+ p2 (list bx bx)))
(command "_.RECTANG" p1 p2)
)
(setvar "CMDECHO" 1)
(prin1)
)
;; e派工具箱内置功能
xyp1964 发表于 2014-7-4 08:41 static/image/common/back.gif
;; e派工具箱内置功能
院长，我那个图片就是你内置的，坦白讲，你的确实很好，但是我们这个行业用不着那么大的工具箱，加载太慢了。。。。让你分离出来。你不愿意。。我只能在这里求兄弟们了。。。 362896182 发表于 2014-7-3 23:42 static/image/common/back.gif
谢谢，兄弟你那个加板框的还有问题，文字是块的那种会出现问题，你的加编号是是很好的，没有问题，zz的编号是不对的，你这个板框和zz的是一样的问题，希望能给改进下 如梦 发表于 2014-7-4 20:52 static/image/common/back.gif
谢谢，兄弟你那个加板框的还有问题，文字是块的那种会出现问题，你的加编号是是很好的，没有问题，zz的编 ...
程序调试没问题。要不给个调试图。 新手路过学习一下，谢谢分享。
页:
[1]
2