[编程交流] 画云笔记，为什么有

(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))
     )
     )
   )
 )
)
)

(setq W0 [color="red"](abs (car (apply 'mapcar (cons '-[/color] (HH:String:Len "" str2 Textheigh 1))))))

(apply 'mapcar (cons '- [color="red"]{must be lists}[/color] )) 

(setq W0 (HH:String:Len "" str2 Textheigh 1))

(setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str2 Textheigh 1))))))

(setq W0 (HH:String:Len "" str2 Textheigh 1))

HHXD:makelt 
MtextDivde

parse3
EntmakeLine

(setq DDJD3 (strcat "[color="red"]?[/color]Modify" DDJD3 "times"))

(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)))
)