Jump to content

automatic font changing - shx to arial ttf font

exceed

By exceed
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

exceed Proficient

exceed

Posted
Posted (edited)

1981909819_2022-02-14142346.thumb.gif.c04b34ff9ff38d4210dcecad3cbd5f75.gif

 

http://www.lee-mac.com/boxtext.html

I made this using this code of lee mac. I've modified it a bit and most of it is his code.

 

It was created to make it easy to create searchable pdf files.

(In the shx state has some problem as we all know 

width limited to 1, or printing with PDFSHX as comments, or printing with microstation, or using adobe ocr. etc...)


 

If the space occupied by the shx font and the space occupied by the ttf font match,

there is no problem in most drawings, so I thought like this 

 

Create a bounding box in shx font, convert every STYLE to Arial ttf font,

create a bounding box again, move the starting point (lower-left),

and then adjust the height, and then adjust the width(scale factor).

 

command : AUTOARIAL 

(defun C:AUTOARIAL ( / *error* text_ss text_ss_length text_ss_index text_data text_data_list text_ent text_height text_width text_box text_box_height text_box_width fontstyle text_box2 text_box3 text_box_height3 height_scale text_box4 text_box_width4 width_scale )
    (LM:startundo (LM:acdoc))
    (setvar "cmdecho" 0)
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )


  (setq mtext_ss (ssget "X" '((0 . "MTEXT")) ) )
  (command "_.explode" mtext_ss "")  
  (command "_.regen")


  (setq text_ss (ssget "X" '((0 . "TEXT")) ) )
  (setq text_ss_length (sslength text_ss))
  (setq text_ss_index 0)
  (setq text_data_list nil)
  (setq text_ent nil)

  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_height (cdr (assoc 40 text_ent)))
     (setq text_width (cdr (assoc 41 text_ent)))
     (setq text_box (text-box-off text_ent 0))
     (setq text_box_height (distance (car text_box) (cadddr text_box)))
     (setq text_box_width (distance (car text_box) (cadr text_box)))
     (setq text_data (list text_ent_name text_height text_width text_box_height text_box_width (car text_box)))
     (setq text_data_list (cons text_data text_data_list))
     (setq text_ss_index (+ text_ss_index 1))
  )


  (setq text_data_list (reverse text_data_list))
  ;(princ text_data_list)

  (setq fontstyle (tblnext "STYLE" T))
  (while fontstyle
    (setq fontstyle (strcase (cdr (assoc 2 fontstyle))))
    (command "style" fontstyle "arial.ttf" "0" "1" "0" "N" "N") 
    (setq fontstyle (tblnext "STYLE"))
  )

 (setq text_box2 nil)
 (setq text_ss_index 0)

  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box2 (text-box-off text_ent 0))
     (vla-move text_obj (vlax-3d-point (car text_box2)) (vlax-3d-point (nth 5 (nth text_ss_index text_data_list))))
     (setq text_ss_index (+ text_ss_index 1))
  )

 (setq text_box3 nil)
 (setq text_box_height3 0)
 (setq text_ss_index 0)
 (setq height_scale 0)

  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box3 (text-box-off text_ent 0))
     (setq text_box_height3 (distance (car text_box3) (cadddr text_box3)))
     (if (= text_box_height3 0)
        (progn )
        (progn 
           (setq height_scale (/ (nth 3 (nth text_ss_index text_data_list)) text_box_height3) ) 
        (vla-put-height text_obj (* (vla-get-height text_obj) height_scale))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  )
  
 (setq text_box4 nil)
 (setq text_box_width4 0)
 (setq text_ss_index 0)
 (setq width_scale 0)


  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box4 (text-box-off text_ent 0))
     (setq text_box_width4 (distance (car text_box4) (cadr text_box4)))
     (if (= text_box_width4 0)
        (progn )
        (progn 
           (setq width_scale (/ (nth 4 (nth text_ss_index text_data_list)) text_box_width4))
           (vla-put-scalefactor text_obj (* (vla-get-scalefactor text_obj) width_scale))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  )



(LM:endundo (LM:acdoc))
(setvar "cmdecho" 1)
(princ)
)



;; Text Box  -  gile / Lee Mac
;; Returns an OCS point list describing a rectangular frame surrounding
;; the supplied text or mtext entity with optional offset
;; enx - [lst] Text or MText DXF data list
;; off - [rea] offset (may be zero)

(defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid )
    (cond
        (   (= "TEXT" (cdr (assoc 00 enx)))
            (setq bpt (cdr (assoc 10 enx))
                  rot (cdr (assoc 50 enx))
                  lst (textbox enx)
                  lst
                (list
                    (list (- (caar  lst) off) (- (cadar  lst) off)) (list (+ (caadr lst) off) (- (cadar  lst) off))
                    (list (+ (caadr lst) off) (+ (cadadr lst) off)) (list (- (caar  lst) off) (+ (cadadr lst) off))
                )
            )
        )
        (   (= "MTEXT" (cdr (assoc 00 enx)))
            (setq ocs  (cdr (assoc 210 enx))
                  bpt  (trans (cdr (assoc 10 enx)) 0 ocs)
                  rot  (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs))
                  wid  (cdr (assoc 42 enx))
                  hgt  (cdr (assoc 43 enx))
                  jus  (cdr (assoc 71 enx))
                  org  (list (cond ((member jus '(2 5 8)) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid))      (0.0))
                             (cond ((member jus '(1 2 3)) (- hgt))      ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0))
                       )
                  lst
                (list
                    (list (- (car org) off)     (- (cadr org) off))     (list (+ (car org) wid off) (- (cadr org) off))
                    (list (+ (car org) wid off) (+ (cadr org) hgt off)) (list (- (car org) off)     (+ (cadr org) hgt off))
                )
            )
        )
    )
    (if lst
        (   (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst))
            (list
                (list (cos rot) (sin (- rot)) 0.0)
                (list (sin rot) (cos rot)     0.0)
               '(0.0 0.0 1.0)
            )
        )
    )
)
 
;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
 
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

sorry for variable is not cleaned

 

 

 

 

======= updated code ========= 

(defun C:AUTOARIAL ( / *error* text_ss text_ss_length text_ss_index text_data text_data_list text_ent text_height text_width text_box text_box_height text_box_width fontstyle text_box2 text_box3 text_box_height3 height_scale text_box4 text_box_width4 width_scale )
    (LM:startundo (LM:acdoc))
    (setvar "cmdecho" 0)
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

  (princ "\n change every STYLE with shx fonts, to Arial ttf font.")

  (setq mtext_ss (ssget "X" '((0 . "MTEXT")) ) )
  (command "_.explode" mtext_ss "")  
  (command "_.regen")


  (setq text_ss (ssget "X" '((0 . "TEXT")) ) )
  
  (setq text_ss_length (sslength text_ss))
  (setq text_ss_index 0)
  (setq text_data_list nil)
  (setq text_ent nil)
  


  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_height (cdr (assoc 40 text_ent)))
     (setq text_width (cdr (assoc 41 text_ent)))
     (setq text_box (text-box-off text_ent 0))
     (setq text_box_height (distance (car text_box) (cadddr text_box)))
     (setq text_box_width (distance (car text_box) (cadr text_box)))
     (setq text_data (list text_ent_name text_height text_width text_box_height text_box_width (car text_box)))
     (setq text_data_list (cons text_data text_data_list))
     (setq text_ss_index (+ text_ss_index 1))
  )


  (setq text_data_list (reverse text_data_list))
  ;(princ text_data_list)

  (setq fontstyle (tblnext "STYLE" T))
  (while fontstyle
    (setq fontstyle (strcase (cdr (assoc 2 fontstyle))))
    (command "style" fontstyle "arial.ttf" "0" "1" "0" "N" "N") 
    (setq fontstyle (tblnext "STYLE"))
  )

 (setq text_box2 nil)
 (setq text_ss_index 0)


 (cond
    ((= 6 (LM:popup "Move BasePoints." "You want to move BasePoint? \n General Case is [ No ]" 36))	
		(princ "\n Move BasePoints.")
  		(repeat text_ss_length
		(setq text_ent (entget (ssname text_ss text_ss_index)))
		(setq text_ent_name (cdr (assoc -1 text_ent)))
		(setq text_obj (vlax-ename->vla-object text_ent_name))
		(setq text_box2 (text-box-off text_ent 0))
		(vla-move text_obj (vlax-3d-point (car text_box2)) (vlax-3d-point (nth 5 (nth text_ss_index text_data_list))))
		(setq text_ss_index (+ text_ss_index 1))
  		)
    )
    (t (princ "\n Do not Move BasePoints."))
  )



 (setq text_box3 nil)
 (setq text_box_height3 0)
 (setq text_ss_index 0)
 (setq height_scale 0)
 
 (cond
    ((= 6 (LM:popup "Round Up the Height" "You want to Round Up the Height?" 36))
		(princ "\n Round Up the Height.")
 (setq roundingh (getreal "\n Input Round Up Factor \n ex) h1500 - input100 / h1510 - input10 / h1511 - input1 "))
 (if (= roundingh nil) (setq roundingh (/ 1 100)))
  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box3 (text-box-off text_ent 0))
     (setq text_box_height3 (distance (car text_box3) (cadddr text_box3)))
     (if (= text_box_height3 0)
        (progn )
        (progn 
           (setq height_scale (/ (nth 3 (nth text_ss_index text_data_list)) text_box_height3) ) 
        (vla-put-height text_obj (LM:roundup (* (vla-get-height text_obj) height_scale) roundingh))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  );end of repeat
  );end of cond 6

   (t (princ "\n no Round Up the Height.")
  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box3 (text-box-off text_ent 0))
     (setq text_box_height3 (distance (car text_box3) (cadddr text_box3)))
     (if (= text_box_height3 0)
        (progn )
        (progn 
           (setq height_scale (/ (nth 3 (nth text_ss_index text_data_list)) text_box_height3) ) 
        (vla-put-height text_obj (* (vla-get-height text_obj) height_scale))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  );end of repeat
    )
  )

 (setq text_box4 nil)
 (setq text_box_width4 0)
 (setq text_ss_index 0)
 (setq width_scale 0)


 (cond
    ((= 6 (LM:popup "Round Up the Width" "You want to Round Up the Width?" 36))
		(princ "\n Round Up the Width.")
  (setq roundingw (getreal "\n Input Round Up Factor \n ex) w1.0 - input1 / w1.1 - input0.1 / w1.01 - input0.01 "))
  (if (= roundingw nil) (setq roundingw (/ 1 100) ))
  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box4 (text-box-off text_ent 0))
     (setq text_box_width4 (distance (car text_box4) (cadr text_box4)))
     (if (= text_box_width4 0)
        (progn )
        (progn 
           (setq width_scale (/ (nth 4 (nth text_ss_index text_data_list)) text_box_width4))
           (vla-put-scalefactor text_obj (LM:roundup (* (vla-get-scalefactor text_obj) width_scale) roundingw))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  );end of repeat
  );end of cond 6
   (t (princ "\n no Round Up the Width.")
  (repeat text_ss_length
     (setq text_ent (entget (ssname text_ss text_ss_index)))
     (setq text_ent_name (cdr (assoc -1 text_ent)))
     (setq text_obj (vlax-ename->vla-object text_ent_name))
     (setq text_box4 (text-box-off text_ent 0))
     (setq text_box_width4 (distance (car text_box4) (cadr text_box4)))
     (if (= text_box_width4 0)
        (progn )
        (progn 
           (setq width_scale (/ (nth 4 (nth text_ss_index text_data_list)) text_box_width4))
           (vla-put-scalefactor text_obj (* (vla-get-scalefactor text_obj) width_scale))
        )
     )
     (setq text_ss_index (+ text_ss_index 1))
  );end of repeat
    )
  )

(LM:endundo (LM:acdoc))
(setvar "cmdecho" 1)
(princ)
)


;; Round Up  -  Lee Mac
;; Rounds 'n' up to the nearest 'm'

(defun LM:roundup ( n m )
    ((lambda ( r ) (cond ((equal 0.0 r 1e-8) n) ((< n 0) (- n r)) ((+ n (- m r))))) (rem n m))
)

;; Round Multiple  -  Lee Mac
;; Rounds 'n' to the nearest multiple of 'm'

(defun LM:roundm ( n m )
    (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5)))
)


;; Round To  -  Lee Mac
;; Rounds 'n' to 'p' decimal places

(defun LM:roundto ( n p )
    (LM:roundm n (expt 10.0 (- p)))
)



;; Text Box  -  gile / Lee Mac
;; Returns an OCS point list describing a rectangular frame surrounding
;; the supplied text or mtext entity with optional offset
;; enx - [lst] Text or MText DXF data list
;; off - [rea] offset (may be zero)

(defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid )
    (cond
        (   (= "TEXT" (cdr (assoc 00 enx)))
            (setq bpt (cdr (assoc 10 enx))
                  rot (cdr (assoc 50 enx))
                  lst (textbox enx)
                  lst
                (list
                    (list (- (caar  lst) off) (- (cadar  lst) off)) (list (+ (caadr lst) off) (- (cadar  lst) off))
                    (list (+ (caadr lst) off) (+ (cadadr lst) off)) (list (- (caar  lst) off) (+ (cadadr lst) off))
                )
            )
        )
        (   (= "MTEXT" (cdr (assoc 00 enx)))
            (setq ocs  (cdr (assoc 210 enx))
                  bpt  (trans (cdr (assoc 10 enx)) 0 ocs)
                  rot  (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs))
                  wid  (cdr (assoc 42 enx))
                  hgt  (cdr (assoc 43 enx))
                  jus  (cdr (assoc 71 enx))
                  org  (list (cond ((member jus '(2 5 8)) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid))      (0.0))
                             (cond ((member jus '(1 2 3)) (- hgt))      ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0))
                       )
                  lst
                (list
                    (list (- (car org) off)     (- (cadr org) off))     (list (+ (car org) wid off) (- (cadr org) off))
                    (list (+ (car org) wid off) (+ (cadr org) hgt off)) (list (- (car org) off)     (+ (cadr org) hgt off))
                )
            )
        )
    )
    (if lst
        (   (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst))
            (list
                (list (cos rot) (sin (- rot)) 0.0)
                (list (sin rot) (cos rot)     0.0)
               '(0.0 0.0 1.0)
            )
        )
    )
)


;; Popup  -  Lee Mac
;; A wrapper for the WSH popup method to display a message box prompting the user.
;; ttl - [str] Text to be displayed in the pop-up title bar
;; msg - [str] Text content of the message box
;; bit - [int] Bit-coded integer indicating icon & button appearance
;; Returns: [int] Integer indicating the button pressed to exit

(defun LM:popup ( ttl msg bit / wsh rtn )
    (if (setq wsh (vlax-create-object "wscript.shell"))
        (progn
            (setq rtn (vl-catch-all-apply 'vlax-invoke-method (list wsh 'popup msg 0 ttl bit)))
            (vlax-release-object wsh)
            (if (not (vl-catch-all-error-p rtn)) rtn)
        )
    )
)

 
;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
 
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

add move base point option (this option for characters that use below the baseline, like p, g, q, but I think it's unnecessary in general)

add width & height round up options

 

ex) autoarial - N - N - N

make Text like 1921.123 Height & 0.8782 Width 

 

All text can have different values

 

ex ) autoarial - N - Y - 100 - Y - 0.1 

makes Text like 1900 Height & 0.9 Width

 

Texts can have an organized values

 

If you set the round up factor well, you can get a clean drawing.

Edited by exceed
  • Like 2
Link to comment
Share on other sites
  • exceed changed the title to automatic font changing - shx to arial ttf font

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...