- UID
- 675606
- 积分
- 3400
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2013-5-6
- 最后登录
- 1970-1-1
|
马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
本帖最后由 /db_自贡黄明儒_ 于 2014-10-27 08:14 编辑
;;未知函数见我的其它贴子;;http://bbs.xdcad.net/forum.php?m ... sortid%26sortid%3D1
;;界面简洁
;;实际上，圆形和矩形是难包罗修改对象的 - ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18
- ;;164.1 [功能] 曲线是否封闭
- ;;示例(HH:isClosed (car (entsel)))
- (defun HH:isClosed (obj)
- (or (vlax-curve-isclosed e)
- (equal (vlax-curve-getstartpoint e)
- (vlax-curve-getendpoint e)
- 1e-5
- )
- )
- )
- ;;164.2 [功能]使多段线封闭
- ;;(HH:MakeClosed (car(entsel)))
- (defun HH:MakeClosed (en / OBJ)
- (cond ((equal (type en) 'ENAME) (setq obj (vlax-ename->vla-object en)))
- (T (setq obj en))
- )
- ;;(if (equal (vlax-get obj 'Closed) 0) (vlax-put obj 'Closed -1))
- ;;(equal (vlax-get-property obj 'closed) :vlax-false)
- ;;(vlax-put-property obj 'closed :vlax-true)
- (cond ((not (vlax-curve-isclosed obj)) (vla-put-closed obj :vlax-true)))
- )
- ;;[功能] 调用Autocad自身命令
- ;;(HH:command "PLINE")
- (defun HH:command (commandstr / E E0)
- (setq e0 (entlast))
- (apply 'command (list (strcat "_." commandstr)))
- (while (equal (getvar "cmdnames") commandstr) (command pause))
- (setq e (entlast))
- (cond ((not (equal e0 e)) e))
- )
- ;;[功能] 画多段线
- (defun HH:XD:Pline (/ E EN)
- (cond
- ((setq e (HH:command "PLINE")) ;成功画得多段
- (setq en (entget e))
- (cond
- ;;没封闭,使其封闭
- ((> (cdr (assoc 90 en)) 2) (cond ((not (HH:isClosed e)) (HH:MakeClosed e))))
- (T (entdel e)) ;少于3点，则删除
- )
- e
- )
- )
- )
- ;;167.6 [功能] Entmake单行文本(左中)
- ;;(EntmakeLMTEXT "DDDD" (getpoint) Textheigh)
- (defun EntmakeLMTEXT (str pt Textheigh)
- ;;(SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字高
- (entmakeX
- (list '(0 . "TEXT")
- (cons 1 str)
- (cons 10 pt)
- (cons 40 Textheigh)
- (cons 11 pt)
- '(73 . 2)
- )
- )
- )
- ;;167.8 [功能] Entmake多行文本(左上角)
- ;;(EntmakeMtext "ABC\\PDEF\\PGHI" (getpoint))
- (defun EntmakeMtext (str pt Textheigh)
- (entmakeX
- (list '(0 . "MTEXT")
- '(100 . "AcDbEntity")
- '(100 . "AcDbMText")
- ;;'(7 . "Standard")
- (cons 1 str)
- (cons 10 pt)
- (cons 40 Textheigh)
- )
- )
- )
- ;;注释放置位置
- ;;(TextPlace (car (entsel)))
- (defun HH:TextPlace (e DDJD1 DDJD2 / CODE DATE EN ENTDAT ENTM ENTNAME LST LST0 P P0 P1 PS PS1 PTS STR TEXTHEIGH X Y)
- (setq Lst0 (parse3 (strcat "注释:" DDJD2) "[\\u4E00-\\u9FA5]|[^\\u4E00-\\u9FA5/ ]|[\\s]+"))
- (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字高
- (while (and (setq code (grread T 8)) (= (car code) 5) (setq p (cadr code)))
- (setq p0 (vlax-curve-getClosestPointTo e p))
- (redraw)
- (grdraw p p0 1)
- )
- ;;以Y最大X最小那个角放置文本开始,应该改为刚好放文字在框内更合理
- (cond (p
- (EntmakeLine p p0) ;修订到注释画线
- (while (and (setq code (grread T 8)) (= (car code) 5) (setq p1 (cadr code)))
- (setq pts (list p (list (car p) (cadr p1)) p1 (list (car p1) (cadr p)) p))
- (redraw)
- (mapcar '(lambda (x y) (grdraw x y 1)) pts (cdr pts))
- (setq Y (max (cadr p) (cadr p1)))
- (setq x (min (car p) (car p1)))
- (setq ps (list (+ x Textheigh) (- Y Textheigh Textheigh))) ;ps是文本放置点
- (cond ((not (equal p p1))
- (setq Lst (MtextDivde p p1 Lst0 Textheigh)) ;注释分段
- (setq str (lst->str1 Lst "\\P"))
- (setq en (entget EntM))
- (entmod (subst (cons 1 str) (assoc 1 en) en)) ;更新
- (command "_.move" Entdat EntName EntM "" "non" ps1 "non" ps)
- (setq ps1 ps)
- )
- (T
- (setq date (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD)"))
- (setq date (strcat "时间:" date))
- (setq ps1 ps)
- (setq Entdat (EntmakeLMTEXT date ps1 Textheigh))
- (setq ps (mapcar '- ps (list 0 (* Textheigh 2))))
- (setq EntName (EntmakeLMTEXT (strcat "姓名:" DDJD1) ps Textheigh))
- (setq ps (mapcar '- ps (list 0 (* Textheigh 1.5))))
- (setq EntM (EntmakeMtext (strcat "注释:" DDJD2) ps Textheigh))
- )
- )
- )
- )
- )
- (cond ((and p p1) (command "_.rectang" "non" p "non" p1)))
- )
- ;;文字按给定长度分段
- ;;(MtextDivde (getpoint) (getpoint) '("A" "B" "C" "D" "E" "F" "G") 3)=>
- ;;(("A" "B" "C") ("D" "E" "F") ("G"))
- (defun MtextDivde (p p1 L Textheigh / L1 LST SCOR STR1 STR2 W W0 X)
- (setq Lst L)
- (setq w (abs (- (car p) (car p1)))) ;方框宽度
- (setq w (abs (- w Textheigh Textheigh))) ;左右间隙半个字高
- (while (setq L1 (car Lst))
- (setq Lst (cdr Lst))
- ;;(cond ((and scor (not str1)) (setq str1 (cons " " str1))));加4个空格
- (setq str1 (cons L1 str1))
- (setq str2 (apply 'strcat str1))
- (setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str2 Textheigh 1))))))
- (cond ((> w0 w)
- (setq scor (cons str1 scor))
- (setq str1 nil)
- )
- )
- )
- (cond (str1 (setq scor (cons str1 scor))))
- (reverse (mapcar '(lambda (x) (reverse x)) scor))
- )
- ;;173 [功能] 表->字符串
- ;;(lst->str1 '(("A" "B" "C") ("D" "E" "F") ("G")) "\\P")=>"ABC\\PDEF\\PG"
- (defun lst->str1 (lst del / A)
- (if (cdr lst)
- (strcat (apply 'strcat (car lst)) del (lst->str1 (cdr lst) del))
- (apply 'strcat (car lst))
- )
- )
- ;;创建线型
- (defun HHXD:makelt (str / EXPRT FILE FN TEXTHEIGH W0 Y)
- (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE") 0.5)) ;字高一半
- (setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str Textheigh 1))))))
- (setq w0 (VL-PRINC-TO-STRING w0));线型文字高
- (setq Y (VL-PRINC-TO-STRING (* -0.5 Textheigh)));线在文字中部
- (setq Textheigh (VL-PRINC-TO-STRING Textheigh))
- (setq File (vl-filename-mktemp nil nil ".lin"))
- (setq fn (open file "w"))
- (setq exprt (getvar 'expert))
- (write-line (strcat "*" str ", ---" str "---") fn)
- (write-line (strcat "A," w0 ",-0.01,[" (VL-PRIN1-TO-STRING str)
- ",STANDARD,S=" Textheigh ",R=0.0,X=-0.0,Y=" Y "],"
- (VL-PRINC-TO-STRING (* -1 (strlen str)))
- )
- fn
- )
- (close fn)
- (setvar 'expert 5)
- (command ".-linetype" "load" "*" file "")
- (setvar 'expert exprt)
- (cond (file (vl-file-delete file)))
- )
- ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18
- (defun C:HHXD (/ DDJD1 DDJD2 DDJD3 E OLDCEC OLDCEL OLDLAYER OSM1 RETURN# SCA)
- (defun *error* (msg)
- (vl-bt)
- (cond (*DOC* (_EndUndo *DOC*))) ;块内图元增减
- (while (not (equal (getvar "cmdnames") "")) (command nil))
- (setvar "nomutt" 0)
- (cond (oldCel (setvar 'CELTYPE oldCel)))
- (cond (oldCec (setvar 'CECOLOR oldCec)))
- (cond (oldLayer (setvar 'Clayer oldLayer)))
- (cond (osm1 (setvar "osmode" osm1)))
- (princ "\n 出错啦!")
- (princ)
- )
- ;;设置对话框
- (defun GETDATA ()
- (setq DDJD1 (get_tile "DDJD1"))
- (cond ((equal (setq DDJD2 (get_tile "DDJD2")) "") (setq DDJD2 "修改")))
- (setq DDJD3 (get_tile "DDJD3"))
- (setenv "HuangMR\\XDYX" DDJD1)
- (setenv "HuangMR\\XDYXNum" DDJD3)
- )
- ;;获取对话框用户输入
- (defun SETDATA (/ NAME)
- (setq name (getenv "HuangMR\\XDYX"))
- (cond ((not name) (setq name "黄明儒")))
- (Set_tile "DDJD1" name)
-
- (setq name (getenv "HuangMR\\XDYXNum"))
- (cond ((not name) (setq name "1")))
- (Set_tile "DDJD3" name)
- )
- ;;对话框
- (defun HHXDdia (/ DCLID FN FNAME LIN)
- (setq fname (vl-filename-mktemp nil nil ".dcl"))
- (setq fn (open fname "w"))
- (write-line "HHXDYX : dialog {label = "修定云线(黄明儒)";" fn)
- (write-line " :row{" fn)
- (write-line " : edit_box {label = "姓名";key = "DDJD1";value = "黄明儒";}"
- fn
- )
- (write-line " :spacer { }:spacer { }:spacer { }:spacer { }:spacer { }" fn)
- (write-line " : edit_box {label = "修改次数";key = "DDJD3";value = "1";}"
- fn
- )
- (write-line " }" fn)
- (write-line " : edit_box {label = "说明";key = "DDJD2";value = "修改";}"
- fn
- )
- (write-line " ok_cancel;" fn)
- (write-line "}" fn)
- (close fn)
- (setq fn (open fname "r"))
- (setq dclid (load_dialog fname))
- (while (or (eq (substr (setq lin
- (vl-string-right-trim "" fn)"
- (vl-string-left-trim "(write-line "" (read-line fn))
- )
- )
- 1
- 2
- )
- "//"
- )
- (eq (substr lin 1 (vl-string-search " " lin)) "")
- (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))
- )
- )
- ;;以下根据情况处理
- (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
- (setdata)
- (action_tile "accept" "(getdata)(done_dialog 1)")
- (action_tile "cancel" "(done_dialog 0)")
- (setq return# (start_dialog))
- (unload_dialog dclid)
- (close fn)
- (vl-file-delete fname)
- (princ)
- )
- (vl-load-com)
- (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
- (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
- (_StartUndo *DOC*)
- (setq oldLayer (getvar "Clayer"))
- (cond ((not (tblsearch "layer" "defpoints")) (command "_.layer" "_M" "defpoints" ""))
- (T (setvar 'Clayer "defpoints"))
- )
- (setq oldCec (getvar "CECOLOR"))
- (setvar 'CECOLOR "1")
- (setq SCA (* (getvar "DIMSCALE") 10))
- (princ "\n修定范围")
- (cond ((setq e (HH:XD:Pline))
- (command "_.revcloud" "_A" SCA "" "_o" e "")
- (setq e (entlast))
- (HHXDdia) ;对话框
- (cond
- ((equal return# 1)
- (setq oldCel (getvar 'CELTYPE))
- (setq DDJD3 (strcat "△修改" DDJD3 "次"))
- (cond ((not (tblsearch "LTYPE" DDJD3)) (HHXD:makelt DDJD3)))
- (setvar 'CELTYPE DDJD3)
- (princ "\n注释放置位置")
- (VL-CATCH-ALL-APPLY 'HH:TextPlace (list e DDJD1 DDJD2))
- (cond (oldCel (setvar 'CELTYPE oldCel)))
- )
- )
- )
- )
- (cond (oldCec (setvar 'CECOLOR oldCec)))
- (cond (oldLayer (setvar 'Clayer oldLayer)))
- (_EndUndo *DOC*)
- (gc)
- (princ "\n 黄明儒:修定云线命令 HHXD")
- (princ)
- )
- (princ "\n 黄明儒:修定云线命令 HHXD")
- (princ)
- ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18
|
-
评分
-
| 参与人数 1 | D豆 +5 |
贡献 +1 |
收起
理由
|
 炫翔
| + 5 |
+ 1 |
很给力!经验；技术要点；资料分享奖！ |
查看全部评分
|
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
已领礼包: 
财富等级: 
发表于 2014-10-25 14:42:41
提升卡
置顶卡
沉默卡
变色卡
千斤顶
发表于 2014-10-25 16:59:39
