画云笔记，为什么有
(defun C:TEST (/ 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 ERROR!")
(princ)
)
(defun GETDATA ()
(setq DDJD1 (get_tile "DDJD1"))
(cond ((equal (setq DDJD2 (get_tile "DDJD2")) "") (setq DDJD2 "Modify")))
(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 "Huangmingru")))
(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 = \"Draw the cloud note-Huangmingru\";" fn)
(write-line " :row{" fn)
(write-line ": edit_box {label = \"Name\";key = \"DDJD1\";value = \"Huangmingru\";}"
fn
)
(write-line ":spacer { }:spacer { }:spacer { }:spacer { }:spacer { }" fn)
(write-line ": edit_box {label = \"Edition \";key = \"DDJD3\";value = \"1\";}"
fn
)
(write-line "}" fn)
(write-line " : edit_box {label = \"Explanation\";key = \"DDJD2\";value = \"Modify\";}"
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 "\nDraw a close curve ")
(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 "△Modify" DDJD3 "times"))
(cond ((not (tblsearch "LTYPE" DDJD3)) (HHXD:makelt DDJD3)))
(setvar 'CELTYPE DDJD3)
(princ "\nNotes position ")
(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)
)
(defun _StartUndo (*DOC*)
(_EndUndo *DOC*)
(vla-StartUndoMark *DOC*)
)
(defun _EndUndo (*DOC*)
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark *DOC*)
)
)
(defun HH:STRING:LEN (sty str h scl)
(and (or (not sty)
(= sty "")
(not (tblsearch "style" sty))
)
(setq sty (getvar "textstyle"))
)
(abs
(car
(apply 'mapcar
(cons '-
(textbox (list (cons 1 str) (cons 7 sty) (cons 40 h) (cons 41 scl))
)
)
)
)
)
)
(defun HH:isClosed (obj)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-5
)
)
)
(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)))
)
(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))
)
e
)
)
)
(defun EntmakeLMTEXT (str pt Textheigh)
(entmakeX
(list '(0 . "TEXT")
(cons 1 str)
(cons 10 pt)
(cons 40 Textheigh)
(cons 11 pt)
'(73 . 2)
)
)
)
(defun EntmakeMtext (str pt Textheigh)
(entmakeX
(list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
;;'(7 . "Standard")
(cons 1 str)
(cons 10 pt)
(cons 40 Textheigh)
)
)
)
(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 "Notes:" DDJD2) "[\\u4E00-\\u9FA5]|[^\\u4E00-\\u9FA5/ ]|[\\s]+"));;
(SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE")))
(while (and (setq code (grread T ) (= (car code) 5) (setq p (cadr code)))
(setq p0 (vlax-curve-getClosestPointTo e p))
(redraw)
(grdraw p p0 1)
)
(cond (p
(EntmakeLine p p0)
(while (and (setq code (grread T ) (= (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)))
(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 "Time:" date))
(setq ps1 ps)
(setq Entdat (EntmakeLMTEXT date ps1 Textheigh))
(setq ps (mapcar '- ps (list 0 (* Textheigh 2))))
(setq EntName (EntmakeLMTEXT (strcat "Name:" DDJD1) ps Textheigh))
(setq ps (mapcar '- ps (list 0 (* Textheigh 1.5))))
(setq EntM (EntmakeMtext (strcat "Notes:" DDJD2) ps Textheigh))
)
)
)
)
)
(cond ((and p p1) (command "_.rectang" "non" p "non" p1)))
)
(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))
(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))
)
(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)))
)
(defun HH:STRING:LEN (sty str h scl)
(and (or (not sty)
(= sty "")
(not (tblsearch "style" sty))
)
(setq sty (getvar "textstyle"))
)
(abs
(car
(apply 'mapcar
(cons '-
(textbox (list (cons 1 str) (cons 7 sty) (cons 40 h) (cons 41 scl))
)
)
)
)
)
)
这个函数？犯错误 AFAIK函数mapcar参数必须是listp或consp
HH:String:Len返回numberp
(setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str2 Textheigh 1))))))
(apply 'mapcar (cons '- {must be lists} ))
我建议省略映射两次，所以只需这样做
(setq W0 (HH:String:Len "" str2 Textheigh 1))
我建议使用setbulge方法，但不确定是否比revcloud更快？
改变
(setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str2 Textheigh 1))))))
到
(setq W0 (HH:String:Len "" str2 Textheigh 1))
我测试过，但没有成功 需要帮助！请看一看！谢谢 嗨，艾伯托，
您只需要按照第#3篇中的建议，为每个子函数进行2次替换
HHXD:makelt
MtextDivde
此外，您没有包括所有子功能（缺失？）
所以我假设这些子函数可以工作。
请查看HH:TextPlace
parse3
EntmakeLine
也可能是包含“/\：；”的无效名称"?*|,=`"
（setvar“CELTYPE”？..）；拒绝
HHXDdia内部
(setq DDJD3 (strcat "?Modify" DDJD3 "times"))
================================================
非常感谢你，我的朋友hanhphuc
一些功能缺失，
(defun XD::String:RegExpS (pat str key / end keys matches x)
(if (not *xxvbsexp)
(setq *xxvbsexp (vlax-get-or-create-object "VBScript.RegExp"))
)
(vlax-put *xxvbsexp 'Pattern pat)
(if (not key)
(setq key "")
)
(setq key (strcase key))
(setq keys '(("I" "IgnoreCase")
("G" "Global")
("M" "Multiline")
)
)
(mapcar
'(lambda (x)
(if (wcmatch key (strcat "*" (car x) "*"))
(vlax-put *xxvbsexp (read (cadr x)) 0)
(vlax-put *xxvbsexp (read (cadr x)) -1)
)
)
keys
)
(setq matches (vlax-invoke *xxvbsexp 'Execute str))
(vlax-for x matches (setq end (cons (vla-get-value x) end)))
(reverse end)
)
;;========================================================
(defun parse3 (str delim)
(xd::string:regexps delim str "")
)
(defun EntmakeLine (pt1 pt2)
(entmake (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2)))
)
(defun HH:String:Len (sty str h scl)
(if (or (not sty)
(= sty "")
(not (tblsearch "style" sty))
)
(setq sty (getvar "textstyle"))
)
(textbox (list (cons 1 str) (cons 7 sty) (cons 40 h) (cons 41 scl)))
)
页:
[1]