Topic: A text font lisp

[BREZI]

Anybody got a lisp routine to change all fonts to be the same in a drawing?

much obliged!

 

[Mark]

qselect!!

[BREZI]

Cheers use that already its good.

Tell my problem, we get loads of architects drawings with loads of fonts, our standard procedure we change all fonts to romans.

I was think I could use ezscript to run a lisp on afolder of drawings during lunch time or somthing like that.

Im still learning lisp, not good at doing my own yet, I can edit and tweak existing ones no probs.

[Kerry]

BREZI,

One solution that doesn't require modifying the drawings is to remove ALL the font definitions other than ROMANS, and update your font mapping file accordingly.

.. That way when you get revisions to the reference drawings you wont have to repeat the process.

.. .. and it can be demonstrated that you haven't made modifications to design documents .. which may, or may not, be important one day.

[BREZI]

Good idea, but;

Unfortunately I have to produce presentation drawings sometimes, and then we use all of the fancy drawings, and we have to print architects drawings exactly as issued for record purposes.

thanks )

[Kerry]

Sure ..
Options, -> Files -> Font File Location

Have 2 folders, one for presentation, one for your special needs.
Flip a switch, you have them all back.
... something you wont have if you change the Font physically

kwb

[David Hall]

I dont have a LISP version, but I have a vba routine that will do it.  It can be called from a script as well

[BREZI]

I dont have a LISP version, but I have a vba routine that will do it.  It can be called from a script as well

That would be cool.

cheers.

[David Hall]

I can upload the file if you need it. Here is the code

Code: [Select]

Option Explicit

Public Sub ChangeTextToRomans()
  Dim objSelected As Object
  Dim objTxt As AcadText
  Dim objstyle As AcadTextStyle
  Dim objLayer As AcadLayer
  Dim objSelSet As AcadSelectionSet
  Dim intAnswer As Integer
  On Error GoTo ErrControl

Set objstyle = ThisDrawing.TextStyles.Add("ROMANS")
objstyle.fontFile = "romans.shx"
objstyle.Width = 1#

  Set objSelSet = ThisDrawing.SelectionSets.Add("Text")
  objSelSet.Select acSelectionSetAll
    For Each objSelected In objSelSet
        If TypeOf objSelected Is AcadText Then
        Set objTxt = objSelected
            If UCase(objTxt.StyleName) <> "ROMANS" Then
            objTxt.StyleName = "ROMANS"
            objTxt.ScaleFactor = 1#
            Else
            objTxt.ScaleFactor = 1#
            End If
        End If
    Next
  ThisDrawing.SelectionSets.Item("Text").Delete
  ThisDrawing.Application.Update
Exit_Here:
  Exit Sub
ErrControl:
  MsgBox Err.Description
End Sub

[David Hall]

your script would look something like

open "your dwg name" (command "-vbarun" "E:/TextToRomans.dvb!ThisDrawing.ChangeTextToRomans") qsave close

all you would have to do is change paths to match yours

[BREZI]

Thats great cheers for the help!

[David Hall]

Glad it worked!  You might need to tweak some of the settings like width factor or preset height.  Also, I didn't put in the error checking to see if the Selection Set existed or not, so that can be added.  I have that code if you need it.

[BREZI]

Dumb question, but how I turn that code into a dvb file?

Never done that before, only worked with lisp & scripts.

[ronjonp]

Hey cmdrduh,

I'm trying to set a font to arial.ttf but it wont work??

Code: [Select]


Dim objstyle As AcadTextStyle

Set objstyle = ThisDrawing.TextStyles.Add("Arial")
objstyle.fontFile = "arial.ttf"
objstyle.Width = 1#

Doest this not work with True Type Fonts?

Thanks,

Ron

[David Hall]

Brezi, I'll upload the file, but in a nutshell, open VBAman, create a new project, and add to ThisDrawing or a module of your choice.  Ronjonp, ill post that in a minute

[David Hall]

Code: [Select]

Set objstyle = ThisDrawing.TextStyles.Add("TEP-TITLE")
objstyle.fontFile = "VERDANA.TTF"
objstyle.Width = 0.85
I use this for verdana, should work for arial.  Ill test in a minute

[David Hall]

Brezi, here is link

[David Hall]

Ronjonp, Autocad cannot find the font under normal pathing, so if you put the ttf in the font folder under autocad, it will work.

[David Hall]

Here is both fonts being loaded

Code: [Select]

Option Explicit

Public Sub ChangeTextToRomans()
  Dim objSelected As Object
  Dim objTxt As AcadText
  Dim objstyle As AcadTextStyle
  Dim objLayer As AcadLayer
  Dim objSelSet As AcadSelectionSet
  Dim intAnswer As Integer
  On Error GoTo ErrControl

Set objstyle = ThisDrawing.TextStyles.Add("ROMANS")
objstyle.fontFile = "romans.shx"
objstyle.Width = 1#
Set objstyle = ThisDrawing.TextStyles.Add("Arial")
objstyle.fontFile = "ARIAL.TTF"
objstyle.Width = 0.85

  Set objSelSet = ThisDrawing.SelectionSets.Add("Text")
  objSelSet.Select acSelectionSetAll
    For Each objSelected In objSelSet
        If TypeOf objSelected Is AcadText Then
        Set objTxt = objSelected
            If UCase(objTxt.StyleName) <> "ROMANS" Then
            objTxt.StyleName = "ROMANS"
            objTxt.ScaleFactor = 1#
            Else
            objTxt.ScaleFactor = 1#
            End If
        End If
    Next
  ThisDrawing.SelectionSets.Item("Text").Delete
  ThisDrawing.Application.Update
Exit_Here:
  Exit Sub
ErrControl:
  MsgBox Err.Description
End Sub


[David Hall]

Just tested this, if you path the font in windows, it will work W/O coping the font to the font folder.  Im going to test if it works after you close acad

[David Hall]

It held it after I closed autocad.  So, you could path it if needed

Code: [Select]

Set objstyle = ThisDrawing.TextStyles.Add("TEP-TITLE")
objstyle.fontFile = "C:\WINNT\Fonts\ARIAL.TTF"
objstyle.Width = 0.85

[ronjonp]

It works just as long as the font is in one of Acad search paths.

Thanks for your help.

Ron

[BREZI]

Cheers again, will let you know tmrw how I get on.

[ronjonp]

Scratch that....I had the font in a search path still....when I took it out it failed.

[BREZI]

Still not got it working, ive been too busy.

I will report back when I get back onto doing the plans.

[Jürg Menzi]

You can use something like this:

Code: [Select]

(defun C:SetTextFont ( / AcaDoc FntFil FntPth NewFnt WscObj)
 (vl-load-com)
 (setq NewFnt "romans.shx"
       AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
       WscObj (vlax-create-object "WScript.Shell")
       FntPth (vla-Item (vlax-get WscObj 'SpecialFolders) "Fonts")
       FntFil (cond
               ((findfile NewFnt) NewFnt)
               ((findfile (strcat FntPth "\\" NewFnt)))
               (T nil)
              )
 )
 (vlax-release-object WscObj)
 (if FntFil
  (progn
   (vla-StartUndoMark AcaDoc)
   (vlax-for Sty (vla-get-TextStyles AcaDoc)
    (vla-put-FontFile Sty FntFil)
   )
   (vla-Regen AcaDoc acAllViewports)
   (vla-EndUndoMark AcaDoc)
  )
  (alert (strcat "Requested font file " NewFnt " not found. "))
 )
 (princ)
)

[Crank]

It's easy to let all textstyles point to the same fontfile. There is no need for a program to do that.
But if you want to do things right, then you've got to change all the text to the same textstyle.

[mojocole]

Enjoyed reading this thread, but didn't find anything elegant to change a dimension style to a new font  (unless I'm missing something about VBA). So, here is my rough n ready script.
This is intended to run in a drawing in which there already exists the dim style you want, and the desired effect will be:

1)to modify that dim style to display romans font, and

2) change all dimensions to that dim style

You'll of course have to edit the text style name "ROMANS" and dim style name "DIM-ROMANS" as desired. You may also have to manually adjust the dimscale of the drawing after running the script, depending on the scale called for in the dimstyle setting, but the font will be changed as intended.
Hope this is helpful to someone. Comments welcome.
cheers
jc

________________________________________________
undo
m
undo
m
-style
ROMANS-AY
romans
0
.8
0
n
n
n
-dimstyle
restore
AYDIM
dim

dimtxsty
ROMANS-AY
exit
ssx

e
dimension

dim
up
p

exit
_____________________________________________________________________

[mojocole]

wowie-zowie.. this thing is powerful. Even changes text styles inside blocks, inside dimensions, and Mtext. ...and it's lightning fast. I have to be careful how I use it -- some things I don't want changed. It would be great to have another version (in addition), which acts only on a selection set.

Thanks, Jurg.

cheers,
jc

You can use something like this:

Code: [Select]

(defun C:SetTextFont ( / AcaDoc FntFil FntPth NewFnt WscObj)
 (vl-load-com)
 (setq NewFnt "romans.shx"
       AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
       WscObj (vlax-create-object "WScript.Shell")
       FntPth (vla-Item (vlax-get WscObj 'SpecialFolders) "Fonts")
       FntFil (cond
               ((findfile NewFnt) NewFnt)
               ((findfile (strcat FntPth "\\" NewFnt)))
               (T nil)
              )
 )
 (vlax-release-object WscObj)
 (if FntFil
  (progn
   (vla-StartUndoMark AcaDoc)
   (vlax-for Sty (vla-get-TextStyles AcaDoc)
    (vla-put-FontFile Sty FntFil)
   )
   (vla-Regen AcaDoc acAllViewports)
   (vla-EndUndoMark AcaDoc)
  )
  (alert (strcat "Requested font file " NewFnt " not found. "))
 )
 (princ)
)