Jump to content

Draw the cloud note , why have error ? please have a look! Thanks!

AIberto

By AIberto
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

AIberto Collaborator

AIberto

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

Link to comment
Share on other sites
AIberto Collaborator

AIberto

Posted
  • Author
Posted 

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

 

This function ? err ?

Link to comment
Share on other sites
hanhphuc Mentor

hanhphuc

Posted
Posted

AFAIK function mapcar argument must be listp or consp

HH:String:Len returns numberp

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

i suggest to omit mapping twice, so simply do this

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

 

i'll suggest using setbulge method but not sure faster than revcloud?

Link to comment
Share on other sites
AIberto Collaborator

AIberto

Posted
  • Author
Posted
AFAIK function mapcar argument must be listp or consp

HH:String:Len returns numberp

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

i suggest to omit mapping twice, so simply do this

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

 

i'll suggest using setbulge method but not sure faster than revcloud?

 

change

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

to

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

 

I test ,but don't succeed

Link to comment
Share on other sites
hanhphuc Mentor

hanhphuc

Posted
Posted
change

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

to

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

 

I test ,but don't succeed

hi Aiberto,

you just need to make 2 replacements for each sub-function as suggested in post#3

HHXD:makelt 
MtextDivde

 

Besides, you did not include all sub-function (missing?)

so i just assumed these sub-functions working.

please look into HH:TextPlace

parse3
EntmakeLine

 

also maybe invalid name which contains "/\:;""?*|,=`"

(setvar 'CELTYPE "?...."); rejected

inside HHXDdia

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

:)

Link to comment
Share on other sites
AIberto Collaborator

AIberto

Posted
  • Author
Posted
hi Aiberto,

you just need to make 2 replacements for each sub-function as suggested in post#3

HHXD:makelt 
MtextDivde

 

Besides, you did not include all sub-function (missing?)

so i just assumed these sub-functions working.

please look into HH:TextPlace

parse3
EntmakeLine

 

also maybe invalid name which contains "/\:;""?*|,=`"

(setvar 'CELTYPE "?...."); rejected

inside HHXDdia

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

:)

 

================================================

Thank you so much , my friend hanhphuc

some function miss, 

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

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...