TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: cmwade77 on September 13, 2019, 07:04:55 PM

Title: SHX to TTF
Post by: cmwade77 on September 13, 2019, 07:04:55 PM

We now have several projects that require us to hyperlink all of our detail callouts in our PDFs, manually doing this takes forever. I have found that with Bluebeam I can make the links automatically if the text uses TTF fonts, unfortunately we have been using SHX fonts forever, including RomanS. As many undoubtedly know, the RomanS TTF doesn't plot very nicely; however, I was able to make a version of it that does work.

Now we have tons of drawings that need to be converted over, some projects have 100+ sheets in them, so I have turned to LISP to automate changing it over.

For my fist stab, I setup a routine that changes based on the stylename:

Code: [Select]

(defun C:FontReMap ()
    (changefont "Callout" "Helvetica Bold.ttf")
    (changefont "RAH_PE" "Helvetica Bold.ttf")
    (changefont "SHTITLE" "Helvetica Bold.ttf")
    (changefont "Arch-Dim" "RomanS_New.ttf")
    (changefont "IT-B" "RomanS_New.ttf")
    (changefont "PAPER_SPACE_TABLE_TEXT_TYPE_PS_TABLE_ROMANS" "RomanS_New.ttf")
    (changefont "ROMAND" "RomanS_New.ttf")
    (changefont "ROMANS" "RomanS_New.ttf")
    (changefont "ROMANSTTF" "RomanS_New.ttf")
    (changefont "Standard" "RomanS_New.ttf")
    (changefont "Style1" "RomanS_New.ttf")
    (changefont "TEXTS" "RomanS_New.ttf")
    (changefont "-30" "RomanS_New.ttf")
    (changefont "C-Font" "RomanS_New.ttf")
    (changefont "CALLOUTS" "RomanS_New.ttf")
    (changefont "S-TEXT" "RomanS_New.ttf")
    (changefont "Table_ROMANS" "RomanS_New.ttf")
    (changefont "$0$ROMANS" "RomanS_New.ttf")
    (changefont "S1" "RomanS_New.ttf")
    (changefont "conduit" "RomanS_New.ttf")
    (changefont "Titles" "Helvetica Bold.ttf")
    (changefont "TEXT" "RomanS_New.ttf")
    (changefont "SIMPLEX" "RomanS_New.ttf")
    (changefont "SANSSERIF" "RomanS_New.ttf")
    (changefont "ROMANSSOV" "RomanS_New.ttf")
    (changefont "note" "RomanS_New.ttf")
    (changefont "conduit-it3" "RomanS_New.ttf")
    (changefont "cleader" "RomanS_New.ttf")
    (changefont "BEI_TITLES" "Helvetica Bold.ttf")
    (changefont "Annotative" "RomanS_New.ttf")
    (changefont "AA-ROMANS" "RomanS_New.ttf")
    (changefont "ATT_ROMANS" "RomanS_New.ttf")
    (command "._regenall")
)

(defun changefont (StyleName NewFont / Doc sty sname FntPth FntNoExt TypeFace cBold cItalic CharSet P&Fam FontExt ChangeFont)
  (vl-load-com)
  (setq	doc (vla-get-activedocument
	      (vlax-get-acad-object)
	    )
  )
  (vla-startundomark doc)
  (if (wcmatch (strcase (getvar "platform")) "*WINDOWS*")
    (if (findfile (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
      (setq FntPth (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
      (setq FntPth (findfile NewFont))
    )
    (setq FntPth (findfile NewFont))
   )
   (setq FntNoExt (vl-filename-base FntPth))
   (if (= Bold T)
    (setq Bold :vlax-true)
    (setq Bold :vlax-false)
   )
   (if (= Italic T)
    (setq Italic :vlax-true)
    (setq Italic :vlax-false)
   )
   (setq sty (vla-get-textstyles doc))
   (vlax-for s sty
    (setq sname (vla-get-name s))
    (if (= (strcase sname) (strcase StyleName))
        (progn
            (setq cFontFile (vla-get-fontfile s)
                  FontExt (vl-filename-extension cFontFile)
                  ChangeFont T
            )
            (if (/= FontExt nil)
                (if (= (strcase FontExt) (strcase ".ttf"))
                    (setq ChangeFont nil)
                )
            )
            (if (/= ChangeFont nil)
                (progn
                    (vla-put-fontfile s FntPth)
                )
            )
        )
    )
   )
  (vla-endundomark doc)
  (princ)
)

This approach does work; however, there are some issues that need to be addressed:

Depending on the number styles and amount of text in the drawing, it can take quite some time
This means you have to specify every individual style seperately

Item 2 is the most problematic, as I am sure we could all put our heads together and solve problem 1, so I figured I would take a crack at making it where I would substitute based on the font name used instead of based on style name:

Code: [Select]

(defun subfont (OldFont NewFont / FntPth cFont CFontBase)
    (if (wcmatch (strcase (getvar "platform")) "*WINDOWS*")
        (if (findfile (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
          (setq FntPth (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
          (setq FntPth (findfile NewFont))
        )
        (setq FntPth (findfile NewFont))
    )
        (vlax-for st (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object)))
        (setq cFont (vla-get-fontfile st))
        (if (= (strcase cFont) (strcase OldFont))
            (progn
                (vla-put-fontfile st FntPth)
            )
        )
    )
)

(defun C:FontSub ()
    (subfont "helvbld" "Helvetica Bold.ttf")
    (subfont "hlvm1d" "Helvetica Bold.ttf")
    (subfont "helvm2" "Helvetica Bold.ttf")
    (subfont "romans" "RomanS_New.ttf")
    (subfont "romand" "RomanS_New.ttf")
    (subfont "romans_struc" "RomanS_New.ttf")
    (subfont "simplex" "RomanS_New.ttf")
    (subfont "x-hlvm1d" "Helvetica Bold.ttf")
    (subfont "osafrac" "RomanS_New.ttf")
    (subfont "txt" "RomanS_New.ttf")
    (command "._regenall")
    (princ)
)

For some reason this method doesn't seem to work, so I am turning to all of you here to see if anyone has any good suggestions? Also, just to be safe, I did check Lee-Mac's site to make sure he didn't already have something, as 9 times out of 10 he at least already has something I can use as a starting point.

Title: Re: SHX to TTF
Post by: tombu on September 13, 2019, 07:34:42 PM

I've used many versions of T.Willey's Merge text styles (or change text styles) for many years: http://www.theswamp.org/index.php?topic=17659.0
Mostly to clean up drawings from consultants. I haven't used an shx font 15 years at least.

Title: Re: SHX to TTF
Post by: cmwade77 on September 13, 2019, 07:43:59 PM

Quote from: tombu on September 13, 2019, 07:34:42 PM

I've used many versions of T.Willey's Merge text styles (or change text styles) for many years: http://www.theswamp.org/index.php?topic=17659.0
Mostly to clean up drawings from consultants. I haven't used an shx font 15 years at least.

While that could certainly work, that is way more complex than I want, I want to be able to specify the old font and what new font it will map to, then run with a single command. I want to set this up once and have it work on all of our drawings.

Title: Re: SHX to TTF
Post by: MP on September 13, 2019, 07:49:15 PM

I can’t post the work I’ve done with text styles and fonts but I can share that it’s very do-able via objectdbx (fast) and we’ve found the Consolas true type font is a good alternate for RomanS. Cheers.

Title: Re: SHX to TTF
Post by: cmwade77 on September 13, 2019, 07:51:35 PM

Ok, I have managed to make this change that works:

Code: [Select]

(defun subfont (OldFont NewFont / Doc sty sname FntPth FntNoExt TypeFace cBold cItalic CharSet P&Fam FontExt ChangeFont)
  (vl-load-com)
  (setq	doc (vla-get-activedocument
	      (vlax-get-acad-object)
	    )
  )
  (vla-startundomark doc)
  (if (wcmatch (strcase (getvar "platform")) "*WINDOWS*")
    (if (findfile (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
      (setq FntPth (strcat (getenv "WINDIR") "\\fonts\\" NewFont))
      (setq FntPth (findfile NewFont))
    )
    (setq FntPth (findfile NewFont))
   )
   (setq FntNoExt (vl-filename-base FntPth))
   (if (= Bold T)
    (setq Bold :vlax-true)
    (setq Bold :vlax-false)
   )
   (if (= Italic T)
    (setq Italic :vlax-true)
    (setq Italic :vlax-false)
   )
   (setq sty (vla-get-textstyles doc))
   (vlax-for s sty
            (setq cFontFile (vla-get-fontfile s)
                  FontExt (vl-filename-extension cFontFile)
                  ChangeFont T
            )
            (if (= (strcase cFontFile) (strcase OldFont))
                (progn
                    (vla-put-fontfile s FntPth)
                )
            )
        
    
   )
  (vla-endundomark doc)
  (princ)
)

(defun C:FontSub ()
    (subfont "helvbld.shx" "Helvetica Bold.ttf")
    (subfont "hlvm1d.shx" "Helvetica Bold.ttf")
    (subfont "helvm2.shx" "Helvetica Bold.ttf")
    (subfont "romans.shx" "RomanS_New.ttf")
    (subfont "romand.shx" "RomanS_New.ttf")
    (subfont "romans_struc.shx" "RomanS_New.ttf")
    (subfont "simplex.shx" "RomanS_New.ttf")
    (subfont "x-hlvm1d.shx" "Helvetica Bold.ttf")
    (subfont "osafrac.shx" "RomanS_New.ttf")
    (subfont "txt.shx" "RomanS_New.ttf")
    (command "._regenall")
    (princ)
)

Title: Re: SHX to TTF
Post by: cmwade77 on September 13, 2019, 07:58:10 PM

Quote from: MP on September 13, 2019, 07:49:15 PM

I can’t post the work I’ve done with text styles and fonts but I can share that it’s very do-able via objectdbx (fast) and we’ve found the Consolas true type font is a good alternate for RomanS. Cheers.

I had tried that one, my boss didn't like it, as I said, I was finally able to modify the RomanS TTF to actually be readable when plotted, in fact as near as I have found, it plots identical to the romans.shx font now.

I have attached it here for those that may need it, please note that I have called the font RomanS_New.

Title: Re: SHX to TTF
Post by: MP on September 14, 2019, 12:06:07 AM

To date those I serve have accepted Consolas as an alternate. The reason Consolas was chosen - aside from it's appearance - was the requirement to use vanilla AutoCAD / Windows fonts. Nonetheless, it is kind and generous of you to share RomanS_New — no doubt others will benefit. Thanks cmwade77.

Title: Re: SHX to TTF
Post by: ronjonp on September 14, 2019, 12:17:49 AM

Quote from: cmwade77 on September 13, 2019, 07:51:35 PM

Ok, I have managed to make this change that works:
Code: [Select]
(defun subfont (OldFont NewFont / Doc sty sname FntPth FntNoExt TypeFace cBold cItalic CharSet P&Fam FontExt ChangeFont) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object) ) ) (vla-startundomark doc) (if (wcmatch (strcase (getvar "platform")) "*WINDOWS*") (if (findfile (strcat (getenv "WINDIR") "\\fonts\\" NewFont)) (setq FntPth (strcat (getenv "WINDIR") "\\fonts\\" NewFont)) (setq FntPth (findfile NewFont)) ) (setq FntPth (findfile NewFont)) ) (setq FntNoExt (vl-filename-base FntPth)) (if (= Bold T) (setq Bold :vlax-true) (setq Bold :vlax-false) ) (if (= Italic T) (setq Italic :vlax-true) (setq Italic :vlax-false) ) (setq sty (vla-get-textstyles doc)) (vlax-for s sty (setq cFontFile (vla-get-fontfile s) FontExt (vl-filename-extension cFontFile) ChangeFont T ) (if (= (strcase cFontFile) (strcase OldFont)) (progn (vla-put-fontfile s FntPth) ) ) ) (vla-endundomark doc) (princ) ) (defun C:FontSub () (subfont "helvbld.shx" "Helvetica Bold.ttf") (subfont "hlvm1d.shx" "Helvetica Bold.ttf") (subfont "helvm2.shx" "Helvetica Bold.ttf") (subfont "romans.shx" "RomanS_New.ttf") (subfont "romand.shx" "RomanS_New.ttf") (subfont "romans_struc.shx" "RomanS_New.ttf") (subfont "simplex.shx" "RomanS_New.ttf") (subfont "x-hlvm1d.shx" "Helvetica Bold.ttf") (subfont "osafrac.shx" "RomanS_New.ttf") (subfont "txt.shx" "RomanS_New.ttf") (command "._regenall") (princ) )

Cmwade I don't see where this will ever return a value other than false?

Code - Auto/Visual Lisp: [Select]

  (if (= bold t)
    (setq bold :vlax-true)
    (setq bold :vlax-false)
  )
  (if (= italic t)
    (setq italic :vlax-true)
    (setq italic :vlax-false)
  )

That being said if it comes into play could be written as this:

Code - Auto/Visual Lisp: [Select]

(setq bold (if bold :vlax-true :vlax-false))
(setq italic (if italic :vlax-true :vlax-false))

Just a quick observation :)

Title: Re: SHX to TTF
Post by: cmwade77 on September 14, 2019, 12:42:18 AM

Quote from: ronjonp on September 14, 2019, 12:17:49 AM

Quote from: cmwade77 on September 13, 2019, 07:51:35 PM
Ok, I have managed to make this change that works:
Code: [Select]
(defun subfont (OldFont NewFont / Doc sty sname FntPth FntNoExt TypeFace cBold cItalic CharSet P&Fam FontExt ChangeFont) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object) ) ) (vla-startundomark doc) (if (wcmatch (strcase (getvar "platform")) "*WINDOWS*") (if (findfile (strcat (getenv "WINDIR") "\\fonts\\" NewFont)) (setq FntPth (strcat (getenv "WINDIR") "\\fonts\\" NewFont)) (setq FntPth (findfile NewFont)) ) (setq FntPth (findfile NewFont)) ) (setq FntNoExt (vl-filename-base FntPth)) (if (= Bold T) (setq Bold :vlax-true) (setq Bold :vlax-false) ) (if (= Italic T) (setq Italic :vlax-true) (setq Italic :vlax-false) ) (setq sty (vla-get-textstyles doc)) (vlax-for s sty (setq cFontFile (vla-get-fontfile s) FontExt (vl-filename-extension cFontFile) ChangeFont T ) (if (= (strcase cFontFile) (strcase OldFont)) (progn (vla-put-fontfile s FntPth) ) ) ) (vla-endundomark doc) (princ) ) (defun C:FontSub () (subfont "helvbld.shx" "Helvetica Bold.ttf") (subfont "hlvm1d.shx" "Helvetica Bold.ttf") (subfont "helvm2.shx" "Helvetica Bold.ttf") (subfont "romans.shx" "RomanS_New.ttf") (subfont "romand.shx" "RomanS_New.ttf") (subfont "romans_struc.shx" "RomanS_New.ttf") (subfont "simplex.shx" "RomanS_New.ttf") (subfont "x-hlvm1d.shx" "Helvetica Bold.ttf") (subfont "osafrac.shx" "RomanS_New.ttf") (subfont "txt.shx" "RomanS_New.ttf") (command "._regenall") (princ) )
Cmwade I don't see where this will ever return a value other than false?
Code - Auto/Visual Lisp: [Select]
(if (= bold t)
(setq bold :vlax-true)
(setq bold :vlax-false)
)
(if (= italic t)
(setq italic :vlax-true)
(setq italic :vlax-false)
)

That being said if it comes into play could be written as this:
Code - Auto/Visual Lisp: [Select]
(setq bold (if bold :vlax-true :vlax-false))
(setq italic (if italic :vlax-true :vlax-false))

Just a quick observation :)

Oops that is actually a remnant from an abandoned part of the code that I found out I didn't need. O should eliminate that one.

Title: Re: SHX to TTF
Post by: GDF on September 16, 2019, 12:04:51 PM

Thanks to everyone for sharing this. I may need this in the future!