Author Topic: A text font lisp  (Read 17323 times)

0 Members and 1 Guest are viewing this topic.

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #15 on: August 17, 2005, 11:50:35 AM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #16 on: August 17, 2005, 11:51:54 AM »
Brezi, here is link
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #17 on: August 17, 2005, 11:54:37 AM »
Ronjonp, Autocad cannot find the font under normal pathing, so if you put the ttf in the font folder under autocad, it will work.
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #18 on: August 17, 2005, 11:55:39 AM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #19 on: August 17, 2005, 11:57:43 AM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
A text font lisp
« Reply #20 on: August 17, 2005, 11:59:39 AM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

ronjonp

  • Needs a day job
  • Posts: 7526
A text font lisp
« Reply #21 on: August 17, 2005, 12:02:32 PM »
It works just as long as the font is in one of Acad search paths.

Thanks for your help.

Ron

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

BREZI

  • Guest
A text font lisp
« Reply #22 on: August 17, 2005, 12:09:27 PM »
Cheers again, will let you know tmrw how I get on.

ronjonp

  • Needs a day job
  • Posts: 7526
A text font lisp
« Reply #23 on: August 17, 2005, 12:10:19 PM »
Scratch that....I had the font in a search path still....when I took it out it failed.

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

BREZI

  • Guest
A text font lisp
« Reply #24 on: August 19, 2005, 05:35:57 AM »
Still not got it working, ive been too busy.

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

Jürg Menzi

  • Swamp Rat
  • Posts: 599
  • Oberegg, Switzerland
A text font lisp
« Reply #25 on: August 19, 2005, 08:45:14 AM »
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)
)
A computer's human touch is its unscrupulousness!
MENZI ENGINEERING GmbH
Current A2k16... A2k24 - Start R2.18

Crank

  • Water Moccasin
  • Posts: 1503
A text font lisp
« Reply #26 on: August 19, 2005, 09:31:14 AM »
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.
Vault Professional 2023     +     AEC Collection

mojocole

  • Guest
Re: A text font lisp
« Reply #27 on: May 07, 2009, 07:07:56 PM »
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

  • Guest
Re: A text font lisp
« Reply #28 on: May 07, 2009, 07:36:46 PM »
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)
)