Jump to content

Recommended Posts

Posted (edited)
(defun ht:chars	(s / l i n c a)
  (setq	l '()
	i 1
	n (strlen s)
  )
  (while (<= i n)
    (setq c (substr s i 1)
	  a (ascii c)
    )
    (if	(and a (> a 127) (< i n))
      (setq l (cons (substr s i 2) l)
	    i (+ i 2)
      )
      (setq l (cons c l)
	    i (1+ i)
      )
    )
  )
  (reverse l)
)
(defun ht:bbox (s hgt wf sty obl / e tb fallback)
  (setq fallback (list (list 0.0 0.0 0.0) (list 0.0 0.0 0.0)))
  (if (or (null s) (= s ""))
    fallback
    (progn
      (setq e (entmakex	(append	(list '(0 . "TEXT")
				      '(100 . "AcDbEntity")
				      '(100 . "AcDbText")
				      '(10 0.0 0.0 0.0)
				      (cons 40 hgt)
				      (cons 1 s)
				      (cons 41 wf)
				      (cons 7 sty)
				      '(72 . 0)
				      '(73 . 0)
				)
				(if obl
				  (list (cons 51 obl))
				  nil
				)
				(list (cons 11 '(0.0 0.0 0.0)))
			)
	      )
      )
      (if e
	(progn
	  (setq tb (textbox (entget e)))
	  (entdel e)
	  (if (and tb (listp tb) (listp (car tb)) (listp (cadr tb)))
	    tb
	    fallback
	  )
	)
	fallback
      )
    )
  )
)
(defun ht:wid (s hgt wf sty obl)
  (car (cadr (ht:bbox s hgt wf sty obl)))
)
(defun ht:layout
       (chars hgt wf sty obl / prefix out result n i x0 x1 totalw)
  (setq	prefix ""
	out '()
  )
  (foreach ch chars
    (setq
      out (cons	(list ch
		      (- (ht:wid (strcat prefix ch) hgt wf sty obl)
			 (ht:wid ch hgt wf sty obl)
		      )
		)
		out
	  )
    )
    (setq prefix (strcat prefix ch))
  )
  (setq	out    (reverse out)
	totalw (ht:wid prefix hgt wf sty obl)
	n      (length out)
	i      0
	result '()
  )
  (while (< i n)
    (setq x0 (cadr (nth i out))
	  x1 (if (< i (1- n))
	       (cadr (nth (1+ i) out))
	       totalw
	     )
    )
    (setq result (cons (list (car (nth i out)) x0 x1) result))
    (setq i (1+ i))
  )
  (reverse result)
)
(defun ht:origin (ed / g72 g73 rot x y cx cy tb mnx mxx mny mxy hgt)
  (setq	g72 (cond ((cdr (assoc 72 ed)))
		  (t 0)
	    )
	g73 (cond ((cdr (assoc 73 ed)))
		  (t 0)
	    )
	rot (cond ((cdr (assoc 50 ed)))
		  (t 0.0)
	    )
	hgt (cdr (assoc 40 ed))
  )
  (if (and (= g72 0) (= g73 0))
    (setq x (car (cdr (assoc 10 ed)))
	  y (cadr (cdr (assoc 10 ed)))
    )
    (setq x (car (cdr (assoc 11 ed)))
	  y (cadr (cdr (assoc 11 ed)))
    )
  )
  (setq	tb  (ht:bbox (cdr (assoc 1 ed))
		     hgt
		     (cdr (assoc 41 ed))
		     (cdr (assoc 7 ed))
		     (cdr (assoc 51 ed))
	    )
	mnx (car (car tb))
	mxx (car (cadr tb))
	mny (cadr (car tb))
	mxy (cadr (cadr tb))
  )
  (setq	cx (cond ((= g72 1) (/ (+ mnx mxx) 2.0))
		 ((= g72 2) mxx)
		 ((= g72 3) 0.0)
		 ((= g72 4) (/ (+ mnx mxx) 2.0))
		 ((= g72 5) mnx)
		 (t mnx)
	   )
	cy (cond ((= g73 1) mny)
		 ((= g73 2) (/ hgt 2.0))
		 ((= g73 3) hgt)
		 (t 0.0)
	   )
  )
  (list	(- x (- (* cx (cos rot)) (* cy (sin rot))))
	(- y (+ (* cx (sin rot)) (* cy (cos rot))))
  )
)
(defun ht:proj (pt base ang)
  (+ (* (- (car pt) (car base)) (cos ang))
     (* (- (cadr pt) (cadr base)) (sin ang))
  )
)
(defun ht:paint	(layout base ang hgt wf lay sty obl from to / out p)
  (setq out '())
  (foreach item	layout
    (if	(and (< (nth 1 item) to) (> (nth 2 item) from))
      (progn (setq p (list (+ (car base) (* (nth 1 item) (cos ang)))
			   (+ (cadr base) (* (nth 1 item) (sin ang)))
			   0.0
		     )
	     )
	     (entmake (append (list '(0 . "TEXT")
				    '(100 . "AcDbEntity")
				    (cons 8 lay)
				    '(100 . "AcDbText")
				    (cons 10 p)
				    (cons 40 hgt)
				    (cons 1 (car item))
				    (cons 50 ang)
				    (cons 41 wf)
				    (cons 7 sty)
				    (cons 62 1)
				    '(72 . 0)
				    '(73 . 0)
			      )
			      (if obl
				(list (cons 51 obl))
				nil
			      )
			      (list (cons 11 p))
		      )
	     )
	     (setq out (cons (entlast) out))
      )
    )
  )
  out
)
(defun ht:clear	(lst)
  (if (listp lst)
    (foreach e lst
      (if (entget e)
	(entdel e)
      )
    )
  )
)
(defun ht:run (sel     /       hEnt    ed      txt     hgt     wf
	       sty     lay     obl     ang     base    anchor-s
	       chars   layout  input   running gr      code    data
	       cur-s   hl-a    hl-b    hl-from hl-to   i       new-lst
	       new-txt echo-last       last-a  last-b
	      )
  (setq	hEnt (car sel)
	ed   (entget hEnt)
  )
  (if (/= "TEXT" (cdr (assoc 0 ed)))
    (princ "\n not a text")
    (progn
      (setq txt	     (cdr (assoc 1 ed))
	    hgt	     (cdr (assoc 40 ed))
	    wf	     (cond ((cdr (assoc 41 ed)))
			   (t 1.0)
		     )
	    sty	     (cond ((cdr (assoc 7 ed)))
			   (t "Standard")
		     )
	    lay	     (cdr (assoc 8 ed))
	    obl	     (cdr (assoc 51 ed))
	    ang	     (cond ((cdr (assoc 50 ed)))
			   (t 0.0)
		     )
	    base     (ht:origin ed)
	    anchor-s (ht:proj (cadr sel) base ang)
	    chars    (ht:chars txt)
	    layout   (ht:layout chars hgt wf sty obl)
      )
      (princ "\n move mouse to change text")
      (setq running T
	    input ""
	    echo-last 0
	    *ht-tmp* '()
	    last-a nil
	    last-b nil
      )
      (while running
	(setq gr   (grread T 13)
	      code (car gr)
	      data (cadr gr)
	)
	(cond
	  ((= code 5)
	   (setq cur-s	 (ht:proj data base ang)
		 hl-from (min anchor-s cur-s)
		 hl-to	 (max anchor-s cur-s)
		 hl-a	 nil
		 hl-b	 nil
		 i	 0
	   )
	   (foreach item layout
	     (if (and (< (nth 1 item) hl-to) (> (nth 2 item) hl-from))
	       (progn (if (null hl-a)
			(setq hl-a i)
		      )
		      (setq hl-b i)
	       )
	     )
	     (setq i (1+ i))
	   )
	   (if (or (/= hl-a last-a) (/= hl-b last-b))
	     (progn (ht:clear *ht-tmp*)
		    (setq *ht-tmp* (if hl-a
				     (ht:paint layout base   ang
					       hgt    wf     lay
					       sty    obl    hl-from
					       hl-to
					      )
				     '()
				   )
		    )
		    (setq last-a hl-a
			  last-b hl-b
		    )
	     )
	   )
	  )
	  ((= code 2)
	   (cond
	     ((member data '(13 32))
	      (if (null hl-a)
		(princ "\n No char to hightlight")
		(progn
		  (setq	i 0
			new-lst	'()
		  )
		  (foreach ch chars
		    (cond ((< i hl-a) (setq new-lst (cons ch new-lst)))
			  ((= i hl-a)
			   (if (> (strlen input) 0)
			     (foreach nc (ht:chars input)
			       (setq new-lst (cons nc new-lst))
			     )
			   )
			  )
			  ((> i hl-b) (setq new-lst (cons ch new-lst)))
			  (t nil)
		    )
		    (setq i (1+ i))
		  )
		  (setq new-txt (apply 'strcat (reverse new-lst)))
		  (if (= new-txt "")
		    (setq new-txt " ")
		  )
		  (entmod (subst (cons 1 new-txt) (assoc 1 ed) ed))
		  (entupd hEnt)
		  (princ (strcat "\n Result: " new-txt))
		)
	      )
	      (setq running nil)
	     )
	     ((= data 8)
	      (if (> (strlen input) 0)
		(setq input (substr input 1 (1- (strlen input))))
	      )
	     )
	     ((= data 27) (setq running nil))
	     ((and (>= data 32) (< data 127))
	      (setq input (strcat input (chr data)))
	     )
	   )
	   (if running
	     (progn
	       (princ (strcat "\r Input: " input))
	       (if (< (strlen input) echo-last)
		 (princ (make-string (- echo-last (strlen input)) 32))
	       )
	       (setq echo-last (strlen input))
	     )
	   )
	  )
	  ((member code '(3 11 25)) (setq running nil))
	)
      )
      (princ)
    )
  )
)
(defun c:HTEXT (/ sel res)
  (setq sel (entsel "\n select a text <exit>: "))
  (if (null sel)
    (princ "\n nothing selected")
    (progn (setq *ht-tmp* '())
	   (setq res (vl-catch-all-apply 'ht:run (list sel)))
	   (ht:clear *ht-tmp*)
	   (setq *ht-tmp* nil)
	   (if (vl-catch-all-error-p res)
	     (princ
	       (strcat "\n error: " (vl-catch-all-error-message res))
	     )
	     (terpri)
	   )
    )
  )
  (princ)
)

Autodesk AutoCAD 2027 - [21楼预制构件图纸.dwg] 2026-09-12 17-54-25.gif

Edited by SLW210
Added Code Tags and formatted code!!
Posted

Please use code tags in the future. (<> in the text editor) and please post the code formatted.

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.

×
×
  • Create New...