TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: BREZI on August 17, 2005, 08:55:02 AM
-
Anybody got a lisp routine to change all fonts to be the same in a drawing?
much obliged!
:D
-
qselect!!
-
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.
-
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.
-
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 :o)
-
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
-
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
-
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.
-
I can upload the file if you need it. Here is the code
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
-
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
-
Thats great cheers for the help!
-
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.
-
Dumb question, but how I turn that code into a dvb file?
Never done that before, only worked with lisp & scripts.
-
Hey cmdrduh,
I'm trying to set a font to arial.ttf but it wont work??
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
-
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
-
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
-
Brezi, here is link (http://www.theswamp.org/lilly_pond/cmdrduh/TextToRomans.dvb?nossi=1)
-
Ronjonp, Autocad cannot find the font under normal pathing, so if you put the ttf in the font folder under autocad, it will work.
-
Here is both fonts being loaded
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
-
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
-
It held it after I closed autocad. So, you could path it if needed
Set objstyle = ThisDrawing.TextStyles.Add("TEP-TITLE")
objstyle.fontFile = "C:\WINNT\Fonts\ARIAL.TTF"
objstyle.Width = 0.85
-
It works just as long as the font is in one of Acad search paths.
Thanks for your help.
Ron
-
Cheers again, will let you know tmrw how I get on.
-
Scratch that....I had the font in a search path still....when I took it out it failed.
-
Still not got it working, ive been too busy.
I will report back when I get back onto doing the plans.
-
You can use something like this:
(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)
)
-
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.
-
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
_____________________________________________________________________
-
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:(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)
)