修定云线
本帖最后由 自贡黄明儒 于 2014-10-25 14:48 编辑;;未知函数见我的其它贴子
;;界面简洁
;;实际上，圆形和矩形是难包罗修改对象的
;;-------------------------------------------画修定云线 自贡黄明儒 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 自贡黄明儒 发表于 2014-11-4 13:43
看了9楼，12楼，问题出在少函数HH:Stringen
;;公用----单行文字角点
;;构造文字长度(abs (car (apply ...
加上这个，还是提示无函数定义_ENDUNDO。大佬能放一个完整的吗？这么好的插件不能运行，太可惜了 无函数定义: _ENDUNDO 早几天看过该动画演示，一直就想着黄大侠的程序了！ 长老，HH:STRING:LEN 这个函数呢? 黄总：2004下运行出错，错误: *error* 函数中出错无函数定义: _ENDUNDO
不知何故？ 2007也上一样的错误 出错无函数定义 连接给的是XD::String:ActualWidth这个函数啊...还是找不到HH:STRING:LEN,麻烦看看 反向跟踪:
(VL-BT)
(*ERROR* "参数列表尾部有错: 5.58222")
(_call-err-hook #<SUBR @148c5e38 *ERROR*> "参数列砦膊坑写? 5.58222")
(sys-error "参数列表尾部有错: 5.58222")
:ERROR-BREAK.33 nil
(APPLY MAPCAR (- . 5.58222))
(HHXD:MAKELT "△修改1次")
(C:HHXD)
(#<SUBR @148c5ed8 -rts_top->)
(#<SUBR @092c2334 veval-str-body> "(C:HHXD)" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0) 黄大师的程序必须学习