« previous next »
Pages: [1] 2  All |   Go Down

Author Topic: Force Arial Font to Display during grread  (Read 8605 times)

0 Members and 1 Guest are viewing this topic.

jvillarreal

  • Bull Frog
  • Posts: 332
Force Arial Font to Display during grread
« on: November 25, 2008, 10:03:28 AM »
Hey all,
I've got a program (mostly composed of stolen code with minor modifications) that will display 'xlist' properties by the cursor during object selection. The problem is, currently, I'm using this little bit of code...(cons 7 "ARIAL")...and it will use the active font during property display if Arial isn't available. I found a function called "af" by ronjonp that would make the arial font active but it was not compatible with 2009 and wouldn't stay consistent as far as the font selected in 2008.
I'm not very experienced and i'm sure something simple can be done to fix the problem. Any Ideas?

Here's the code i'm using now

Code: [Select]
(defun c:ch (/ ActDoc e el kword lyr clr layer linetype obj sObjectType sLineType sColor sBlockname

sStyleName *error*)
(vl-load-com)
(defun *error* ( msg )
        (princ (strcat "\n<" msg ">\n"))
(progn
(and TextENAME (entdel TextENAME))
(vl-cmdf "ucs" "p")
(vla-EndUndoMark ActDoc)
);progn
        (princ)
   )
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))

(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(while (null e) (princ "\nSelect Object on Layer to change: ")
    (setq e (test2))
);while
(setq el (entget e))
(setq lyr (cdr (assoc 8 el)))
(progn
(setq layer (entget
  (tblobjname "layer" lyr)
    )
)

(if (assoc 420 layer)(setq layer (vl-remove (assoc 420 layer) layer)));;new line attached to prevent

true color override
(initget "Color lineType lineWeight")

(setq kword (if
(setq kword (getkword (strcat "Modify " lyr " [ Color / lineType / lineWeight ]:

<Color>")))
  kword "Color")
);setq

(cond
((= kword "Color")
(setq clr (acad_colordlg 0))
(entmod (subst (cons 62 clr) (assoc 62 layer) layer))
);cond 1

((= kword "lineType")
(setq LineTYPE (GetLineType))
(if (/= (getvar "celtype") LineTYPE)
(entmod (subst (cons 6 linetype) (assoc 6 layer) layer))
)
);cond 2

((= kword "lineWeight")
(setq Lineweight (GetLineweight))
(entmod (subst (cons 370 lineweight) (assoc 370 layer) layer))
(vl-cmdf "undo" "")
(vl-cmdf "redo" "")
);cond 3

);condition
);progn
(vl-cmdf "ucs" "p")
(vla-Regen ActDoc acActiveViewport)
(vla-EndUndoMark ActDoc)
(princ)
);defun

;;;;;function test2 Originally by Vovka @ theswamp.org;added viewtwist/ucs world command, xlist code,

and modified viewsize for compatability while in locked $VP
(defun test2 (/ ENAME TextENAME ViewSize sLayer sObjectType sBlockname sStyel Name layer)
(vl-cmdf "ucs" "w")
  (while (and (setq Input (grread T 4 2)) (= (car Input) 5))
    (if TextENAME
      (progn (entdel TextENAME) (setq TextENAME nil))
    )
    (if (and (setq ENAME (car (nentselp (cadr Input))))
     (not (eq TextENAME ENAME))
)
      (progn (if (or (= (getvar "ctab") "Model")(= (getvar "CVPORT") 1))
      (setq viewsize (getvar "VIEWSIZE"))
(setq viewsize (* (/ (getvar "viewsize")(car (getvar "screensize"))) 500))
);if
(setq el (entget ename))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;THIS SECTION IS FROM

XLIST;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if ename
(progn
(setq el (entget ename)
  sLayer (cdr (assoc 8 el))
          sObjectType (cdr (assoc 0 el))
    sLineType (cdr (assoc 6 el)) ; This is optional, we check for it

later.
               sColor (cdr (assoc 62 el))
sBlockname ""
sStyleName ""
layer (entget
  (tblobjname "layer" SLayer)
    )
    );setq

;Check for no linetype override, in which case it is bylayer.
    (if (= sLineType nil) (setq sLineType "ByLayer")) ;Tidy up the optional DXF

codes for linetype
   

;If the object is a vertex, call a vertex a polyline
    (if (= "VERTEX" sObjectType) (setq sObjectType "POLYLINE"))

;If the object is a block, call an insert a block and find out the block name
(if (= "INSERT" sObjectType)
(progn
(setq sObjectType "BLOCK"
sBlockname (cdr (assoc 2 el))
)
);end progn
);end if

;If the object is text or mtext, find out the style name
(if (or (= "TEXT" sObjectType) (= "MTEXT" sObjectType))
(setq sStyleName (cdr (assoc 7 el)))
);end if

; Sort out the colors and assign names to the first 8 plus bylayer and byblock
    (cond ( (= nil sColor) (setq sColor "ByLayer"))
        ( (= 0 sColor) (setq sColor "ByBlock"))
          ( (= 1 sColor) (setq sColor "Red"))
          ( (= 2 sColor) (setq sColor "Yellow"))
( (= 3 sColor) (setq sColor "Green"))
          ( (= 4 sColor) (setq sColor "Cyan"))
          ( (= 5 sColor) (setq sColor "Blue"))
          ( (= 6 sColor) (setq sColor "Magenta"))
          ( (= 7 sColor) (setq sColor "White"))
          ( (= 256 sColor) (setq sColor "ByLayer"))
          (t (setq sColor (itoa sColor)))
    );end cond
);progn
);if
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     (setq TextENAME
    (entmakex
      (list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1
(cond ((and (/= sLineType "ByLayer")(/= sColor "ByLayer"))
      (strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType
   "\nCOLOR: "
   sColor
);strcat
);condition
((and (= sLineType "ByLayer")(= sColor "ByLayer"))
      (strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType " (" (cdr (assoc 6 layer)) ")"
   "\nCOLOR: "
   sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition
((and (= sLineType "ByLayer")(/= sColor "ByLayer"))
(strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType " (" (cdr (assoc 6 layer)) ")"
   "\nCOLOR: "
   sColor
);strcat
);condition
((and (/= sLineType "ByLayer")(= sColor "ByLayer"))
(strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType
   "\nCOLOR: "
    sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition
);cond
)
(cons 7 "ARIAL")
(cons 10
      (polar (cadr Input) 0 (/ ViewSize 50.0))
)
(cons 40 (/ ViewSize 50.0));
(cons 50 (- 0 (getvar "VIEWTWIST")));added viewtwist for readability

(cond ((and (= sLineType "ByLayer")(= sColor "ByLayer"))
(cons 62 250)
);condition
((or (/= sLineType "ByLayer")(/= sColor "ByLayer"))
(cons 62 1)
);condition
);cond
(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 255)
(cons 45 1.2)
      );list
    );entmakex
     );setq
      );progn
    );if
  );while
  (and TextENAME (entdel TextENAME))
  (princ)
ename;for object selection
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end

test2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;
(defun GETLINETYPE (/ CL SL)                     
  (setq CL (getvar "CELTYPE"))
  (initdia)
  (command "_.LINETYPE")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celtype") CL)
   (setq SL (getvar "celtype"))
   (setq SL CL)
  )
  (setvar "celtype" CL)
  SL
 )

(defun GETLINEWEIGHT (/ LW SLW)                     
  (setq LW (getvar "CELWEIGHT"))
  (initdia)
  (vl-cmdf "_.LWEIGHT")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celweight") LW)
   (setq SLW (getvar "celweight"))
   (setq SLW LW)
  )
  (setvar "celweight" LW)
  SLw
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;END LIBRARY

FUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;
« Last Edit: November 25, 2008, 10:25:59 AM by jvillarreal »
Logged

Andrea

  • Water Moccasin
  • Posts: 2372
Re: Force Arial Font to Display during grread
« Reply #1 on: November 25, 2008, 12:05:16 PM »
try this..maybe not good looking...but it work.

Code: [Select]
(defun c:ch (/ ActDoc e el kword lyr clr layer linetype obj sObjectType sLineType sColor sBlockname

sStyleName *error*)

(setq MyCurrentTextStyle (getvar "TEXTSTYLE" ))       
(SetmyFontStyle)
(setvar "TEXTSTYLE" "MYPROGRAMFONT")


 
(vl-load-com)
(defun *error* ( msg )
 
        (princ (strcat "\n<" msg ">\n"))
(progn
(and TextENAME (entdel TextENAME))
(vl-cmdf "ucs" "p")
(vla-EndUndoMark ActDoc)
);progn
  (setvar "TEXTSTYLE" MyCurrentTextStyle)
        (princ)
   )
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))

(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(while (null e) (princ "\nSelect Object on Layer to change: ")
    (setq e (test2))
);while
(setq el (entget e))
(setq lyr (cdr (assoc 8 el)))
(progn
(setq layer (entget
  (tblobjname "layer" lyr)
    )
)

(if (assoc 420 layer)(setq layer (vl-remove (assoc 420 layer) layer)));;new line attached to prevent

true color override
(initget "Color lineType lineWeight")

(setq kword (if
(setq kword (getkword (strcat "Modify " lyr " [ Color / lineType / lineWeight ]:

<Color>")))
  kword "Color")
);setq

(cond
((= kword "Color")
(setq clr (acad_colordlg 0))
(entmod (subst (cons 62 clr) (assoc 62 layer) layer))
);cond 1

((= kword "lineType")
(setq LineTYPE (GetLineType))
(if (/= (getvar "celtype") LineTYPE)
(entmod (subst (cons 6 linetype) (assoc 6 layer) layer))
)
);cond 2

((= kword "lineWeight")
(setq Lineweight (GetLineweight))
(entmod (subst (cons 370 lineweight) (assoc 370 layer) layer))
(vl-cmdf "undo" "")
(vl-cmdf "redo" "")
);cond 3

);condition
);progn
(vl-cmdf "_ucs" "_p")
(vla-Regen ActDoc acActiveViewport)
(vla-EndUndoMark ActDoc)
(princ)
);defun

;;;;;function test2 Originally by Vovka @ theswamp.org;added viewtwist/ucs world command, xlist code,

;;and modified viewsize for compatability while in locked $VP
(defun test2 (/ ENAME TextENAME ViewSize sLayer sObjectType sBlockname sStyel Name layer)
(vl-cmdf "_ucs" "_w")
  (while (and (setq Input (grread T 4 2)) (= (car Input) 5))
    (if TextENAME
      (progn (entdel TextENAME) (setq TextENAME nil))
    )
    (if (and (setq ENAME (car (nentselp (cadr Input))))
     (not (eq TextENAME ENAME))
)
      (progn (if (or (= (getvar "ctab") "Model")(= (getvar "CVPORT") 1))
      (setq viewsize (getvar "VIEWSIZE"))
(setq viewsize (* (/ (getvar "viewsize")(car (getvar "screensize"))) 500))
);if
(setq el (entget ename))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;THIS SECTION IS FROM

XLIST;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if ename
(progn
(setq el (entget ename)
  sLayer (cdr (assoc 8 el))
          sObjectType (cdr (assoc 0 el))
    sLineType (cdr (assoc 6 el)) ; This is optional, we check for it

;;later.
               sColor (cdr (assoc 62 el))
sBlockname ""
sStyleName ""
layer (entget
  (tblobjname "layer" SLayer)
    )
    );setq

;Check for no linetype override, in which case it is bylayer.
    (if (= sLineType nil) (setq sLineType "ByLayer")) ;Tidy up the optional DXF

;;codes for linetype
   

;If the object is a vertex, call a vertex a polyline
    (if (= "VERTEX" sObjectType) (setq sObjectType "POLYLINE"))

;If the object is a block, call an insert a block and find out the block name
(if (= "INSERT" sObjectType)
(progn
(setq sObjectType "BLOCK"
sBlockname (cdr (assoc 2 el))
)
);end progn
);end if

;If the object is text or mtext, find out the style name
(if (or (= "TEXT" sObjectType) (= "MTEXT" sObjectType))
(setq sStyleName (cdr (assoc 7 el)))
);end if

; Sort out the colors and assign names to the first 8 plus bylayer and byblock
    (cond ( (= nil sColor) (setq sColor "ByLayer"))
        ( (= 0 sColor) (setq sColor "ByBlock"))
          ( (= 1 sColor) (setq sColor "Red"))
          ( (= 2 sColor) (setq sColor "Yellow"))
( (= 3 sColor) (setq sColor "Green"))
          ( (= 4 sColor) (setq sColor "Cyan"))
          ( (= 5 sColor) (setq sColor "Blue"))
          ( (= 6 sColor) (setq sColor "Magenta"))
          ( (= 7 sColor) (setq sColor "White"))
          ( (= 256 sColor) (setq sColor "ByLayer"))
          (t (setq sColor (itoa sColor)))
    );end cond
);progn
);if
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
     (setq TextENAME
    (entmakex
      (list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1
(cond ((and (/= sLineType "ByLayer")(/= sColor "ByLayer"))
      (strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType
   "\nCOLOR: "
   sColor
);strcat
);condition
((and (= sLineType "ByLayer")(= sColor "ByLayer"))
      (strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType " (" (cdr (assoc 6 layer)) ")"
   "\nCOLOR: "
   sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition
((and (= sLineType "ByLayer")(/= sColor "ByLayer"))
(strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType " (" (cdr (assoc 6 layer)) ")"
   "\nCOLOR: "
   sColor
);strcat
);condition
((and (/= sLineType "ByLayer")(= sColor "ByLayer"))
(strcat "OBJECT: "
   sObjectType
                           ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                           "\nLAYER: "
                           (cdr (assoc 8 (entget ename)))
   "\nLINETYPE: "
   sLineType
   "\nCOLOR: "
    sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition
);cond
)
(cons 7 "ARIAL")
(cons 10
      (polar (cadr Input) 0 (/ ViewSize 50.0))
)
(cons 40 (/ ViewSize 50.0));
(cons 50 (- 0 (getvar "VIEWTWIST")));added viewtwist for readability

(cond ((and (= sLineType "ByLayer")(= sColor "ByLayer"))
(cons 62 250)
);condition
((or (/= sLineType "ByLayer")(/= sColor "ByLayer"))
(cons 62 1)
);condition
);cond
(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 255)
(cons 45 1.2)
      );list
    );entmakex
     );setq
      );progn
    );if
  );while
  (and TextENAME (entdel TextENAME))
  (setvar "TEXTSTYLE" MyCurrentTextStyle)
  (princ)
ename;for object selection
 
 
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end

;;test2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;
(defun GETLINETYPE (/ CL SL)                     
  (setq CL (getvar "CELTYPE"))
  (initdia)
  (command "_.LINETYPE")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celtype") CL)
   (setq SL (getvar "celtype"))
   (setq SL CL)
  )
  (setvar "celtype" CL)
  SL
 )

(defun GETLINEWEIGHT (/ LW SLW)                     
  (setq LW (getvar "CELWEIGHT"))
  (initdia)
  (vl-cmdf "_.LWEIGHT")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celweight") LW)
   (setq SLW (getvar "celweight"))
   (setq SLW LW)
  )
  (setvar "celweight" LW)
  SLw
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;END LIBRARY

;;FUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;










(defun SetmyFontStyle ()

(if (and
      (member "ARIAL" (GEN_TTF_GET))
      (not (member "MYPROGRAMFONT" (GEN_TEXTSTYLE_get)))
    )

(command "._-style"
"MYPROGRAMFONT" ; name of text style
"ARIAL" ; font name
"0" ; height of text
"1" ; width factor
"0" ; obliquing angle
"N" ; text backwards
"N" ; text upside-down
"N" ; Vertical
)
)
 
)



;;TTF
;| ;
LISTE de TTF ;
|;
(defun GEN_TTF_get (/ lsttf)
;;(setq lstttf (vl-registry-descendents "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts" ""))
(setq lstttf
       (mapcar
  'strcase
  (mapcar
    'vl-filename-base
(vl-registry-descendents "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts" ""))
))

(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (TRUETYPE)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (VGA RES)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (ALL RES)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (TOUTES RÉSOLUTIONS)" x)
)
     lstttf))
)
;;**********************************************;




;;TEXTSTYLE
;| ;
LISTE de TEXTSTYLE ;
|;
(defun GEN_TEXTSTYLE_get (/ i txtcount)
(setq txtcount (vla-get-TextStyles
(vla-get-activedocument (vlax-get-acad-object))
       )
)
(vl-load-com)
(setq StyleList ())
(vlax-for i txtcount
  (setq StyleList (append StyleList (list (vla-get-name i))))
)
  StyleList
)
;;**********************************************;

« Last Edit: November 25, 2008, 12:11:50 PM by Andrea »
Logged
Keep smile...

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #2 on: November 25, 2008, 12:15:27 PM »
Hi Andrea,
Thanks for the reply.
I'm getting an unfilled arial font when using it in a new drawing.
Logged

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #3 on: November 25, 2008, 02:27:35 PM »
To make things simple, i just decided to create a temporary text style using the arial.ttf and delete after program executes..
Logged

Andrea

  • Water Moccasin
  • Posts: 2372
Re: Force Arial Font to Display during grread
« Reply #4 on: November 25, 2008, 02:45:22 PM »
that is what I have modified on the program...
If you got Unfilled text....maybe is the TEXTFILL variable. ?
Logged
Keep smile...

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #5 on: November 25, 2008, 03:07:40 PM »
My textfill var is set to 1..and it turns out your function is using an existing aerial.shx font..
Logged

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #6 on: November 25, 2008, 03:17:34 PM »
Andrea,
I just need to add .ttf to your code for it to work. I guess it was defaulting to the available shx without the extension. Anyway Thank you!! You're awesome!
Code: [Select]
(command "._-style"
"MYPROGRAMFONT" ; name of text style
"ARIAL.TTF" ; font name
"0" ; height of text
"1" ; width factor
"0" ; obliquing angle
"N" ; text backwards
"N" ; text upside-down
"N" ; Vertical
)
Logged

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #7 on: November 25, 2008, 03:43:00 PM »
Here's the completed code if anyone's interested...and thanks again Andrea!(and everyone else who's code is in here) :roll:
***MODIFIED TO DELETE TEMPORARY FONT STYLE***
Code: [Select]
(defun c:ch (/ ActDoc e el kword lyr clr layer linetype obj sObjectType sLineType sColor sBlockname sStyleName *error* *layers MyCurrentTextStyle)
(vl-load-com)

(setq MyCurrentTextStyle (getvar "TEXTSTYLE" ))       
(SetmyFontStyle)
(setvar "TEXTSTYLE" "MYPROGRAMFONT")

(defun *error* ( msg )
(princ (strcat "\n<" msg ">\n"))
(and TextENAME (entdel TextENAME))
(vl-cmdf "ucs" "p")
(vla-EndUndoMark ActDoc)
             (setvar "TEXTSTYLE" MyCurrentTextStyle)
             (VLA-DELETE (vlax-ename->vla-object
  (tblobjname "STYLE" "MYPROGRAMFONT")
   )
              );vla-delete
        (princ)
);defun

(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)

(while (null e) (princ "\nSelect Object on Layer to change: ")
    (setq e (test2))
);while

(setq el (entget e))
(setq lyr (cdr (assoc 8 el)))

(progn
(setq layer (entget
  (tblobjname "layer" lyr)
                    )
)

(if (assoc 420 layer)(setq layer (vl-remove (assoc 420 layer) layer)));;new line attached to prevent true color override

(initget "Color lineType lineWeight Freeze")
(setq kword
(if
(setq kword (getkword (strcat "Modify " lyr " [ Color / lineType / lineWeight / Freeze]: <Color>"))) kword "Color"
);if
);setq

(cond
((= kword "Color")
(setq clr (acad_colordlg 0))
(entmod (subst (cons 62 clr) (assoc 62 layer) layer))
);cond 1

((= kword "lineType")
(setq LineTYPE (GetLineType))
(if (/= (getvar "celtype") LineTYPE)
(entmod (subst (cons 6 linetype) (assoc 6 layer) layer))
);if
);cond 2

((= kword "lineWeight")
(setq Lineweight (GetLineweight))
(entmod (subst (cons 370 lineweight) (assoc 370 layer) layer))
(vl-cmdf "undo" "")
(vl-cmdf "redo" "")
);cond 3

((= kword "Freeze")
(if (/= lyr (getvar "clayer"))
(progn
(setq *layers (vla-get-layers ActDoc))
(setq layer (vla-add *layers lyr))
(vla-put-freeze layer :vlax-true)
);progn
(alert "Can not freeze current layer.")
);if
);cond 4

);condition
);progn

(vl-cmdf "ucs" "p")
(setvar "TEXTSTYLE" MyCurrentTextStyle)
(vla-Regen ActDoc acActiveViewport)
(VLA-DELETE (vlax-ename->vla-object
  (tblobjname "STYLE" "MYPROGRAMFONT")
   )
);vla-delete
(vla-EndUndoMark ActDoc)
(princ)
);defun

;;;;;function test2 Originally by Vovka @ theswamp.org;added viewtwist/ucs world command, xlist code, and modified viewsize for compatability while in locked

$VP
(defun test2 (/ ENAME TextENAME ViewSize sLayer sObjectType sBlockname sStyel Name layer Input)
(vl-cmdf "ucs" "w")
(while (and (setq Input (grread T 4 2)) (= (car Input) 5))
(if TextENAME
(progn (entdel TextENAME) (setq TextENAME nil))
    );if
(if
(and (setq ENAME (car (nentselp (cadr Input))))
(not (eq TextENAME ENAME))
    );and
      (progn
(if (or (= (getvar "ctab") "Model")(= (getvar "CVPORT") 1))
      (setq viewsize (getvar "VIEWSIZE"))
(setq viewsize (* (/ (getvar "viewsize")(car (getvar "screensize"))) 500))
      );if
(setq el (entget ename))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;THIS SECTION IS FROM XLIST;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if ename
(progn
(setq el (entget ename)
  sLayer (cdr (assoc 8 el))
          sObjectType (cdr (assoc 0 el))
    sLineType (cdr (assoc 6 el)) ; This is optional, we check for it later.
               sColor (cdr (assoc 62 el))
sBlockname ""
sStyleName ""
layer (entget
  (tblobjname "layer" SLayer)
    )
    );setq

;Check for no linetype override, in which case it is bylayer.
    (if (= sLineType nil) (setq sLineType "ByLayer")) ;Tidy up the optional DXF codes for linetype
   

;If the object is a vertex, call a vertex a polyline
    (if (= "VERTEX" sObjectType) (setq sObjectType "POLYLINE"))

;If the object is a block, call an insert a block and find out the block name
(if (= "INSERT" sObjectType)
(progn
(setq sObjectType "BLOCK"
sBlockname (cdr (assoc 2 el))
)
);end progn
);end if

;If the object is text or mtext, find out the style name
(if (or (= "TEXT" sObjectType) (= "MTEXT" sObjectType))
(setq sStyleName (cdr (assoc 7 el)))
);end if

; Sort out the colors and assign names to the first 8 plus bylayer and byblock
    (cond ( (= nil sColor) (setq sColor "ByLayer"))
        ( (= 0 sColor) (setq sColor "ByBlock"))
          ( (= 1 sColor) (setq sColor "Red"))
          ( (= 2 sColor) (setq sColor "Yellow"))
( (= 3 sColor) (setq sColor "Green"))
          ( (= 4 sColor) (setq sColor "Cyan"))
          ( (= 5 sColor) (setq sColor "Blue"))
          ( (= 6 sColor) (setq sColor "Magenta"))
          ( (= 7 sColor) (setq sColor "White"))
          ( (= 256 sColor) (setq sColor "ByLayer"))
          (t (setq sColor (itoa sColor)))
    );end cond
);progn
);if
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     (setq TextENAME
    (entmakex
      (list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")

(cons 1
(cond
((and (/= sLineType "ByLayer")(/= sColor "ByLayer"))
      (strcat "OBJECT: "
  sObjectType
                            ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                            "\nLAYER: "
                          (cdr (assoc 8 (entget ename)))
    "\nLINETYPE: "
  sLineType
    "\nCOLOR: "
  sColor
);strcat
);condition

((and (= sLineType "ByLayer")(= sColor "ByLayer"))
      (strcat "OBJECT: "
    sObjectType
                            ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                            "\nLAYER: "
                            (cdr (assoc 8 (entget ename)))
    "\nLINETYPE: "
  sLineType " (" (cdr (assoc 6 layer)) ")"
    "\nCOLOR: "
    sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition

((and (= sLineType "ByLayer")(/= sColor "ByLayer"))
(strcat "OBJECT: "
  sObjectType
                            ;"\nENAME: "
                          ;(vl-princ-to-string ename)
                            "\nLAYER: "
                          (cdr (assoc 8 (entget ename)))
    "\nLINETYPE: "
    sLineType " (" (cdr (assoc 6 layer)) ")"
    "\nCOLOR: "
    sColor
);strcat
);condition

((and (/= sLineType "ByLayer")(= sColor "ByLayer"))
(strcat "OBJECT: "
    sObjectType
                            ;"\nENAME: "
                          ; (vl-princ-to-string ename)
                            "\nLAYER: "
                            (cdr (assoc 8 (entget ename)))
    "\nLINETYPE: "
  sLineType
    "\nCOLOR: "
    sColor " (" (itoa (cdr (assoc 62 layer))) ")"
);strcat
);condition
);cond
);cons 1

(cons 7 "ARIAL")
(cons 10
      (polar (cadr Input) 0 (/ ViewSize 50.0))
)
(cons 40 (/ ViewSize 40.0));
(cons 50 (- 0 (getvar "VIEWTWIST")));added viewtwist for readability

(cond
((and (= sLineType "ByLayer")(= sColor "ByLayer"))
(cons 62 250)
);condition

((or (/= sLineType "ByLayer")(/= sColor "ByLayer"))
(cons 62 1)
);condition
);cond

(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 255)
(cons 45 1.2)
      );list
    );entmakex
     );setq
           );progn
    );if
  );while
  (and TextENAME (entdel TextENAME))
  (princ)
ename;for object selection
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end

test2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GETLINETYPE (/ CL SL)                     
  (setq CL (getvar "CELTYPE"))
  (initdia)
  (command "_.LINETYPE")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celtype") CL)
    (setq SL (getvar "celtype"))
    (setq SL CL)
  );if
  (setvar "celtype" CL)
  SL
 );while

(defun GETLINEWEIGHT (/ LW SLW)                     
  (setq LW (getvar "CELWEIGHT"))
  (initdia)
  (vl-cmdf "_.LWEIGHT")
  (while (= (logand (getvar "CMDACTIVE") 8) 1)  (command pause)  )
  (if (/= (getvar "celweight") LW)
    (setq SLW (getvar "celweight"))
    (setq SLW LW)
  );if
  (setvar "celweight" LW)
  SLw
 );while

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;BY ANDREA @ THESWAMP.ORG;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SetmyFontStyle ()

(if (and
      (member "ARIAL" (GEN_TTF_GET))
      (not (member "MYPROGRAMFONT" (GEN_TEXTSTYLE_get)))
    )

(command "._-style"
"MYPROGRAMFONT" ; name of text style
"ARIAL.TTF" ; font name
"0" ; height of text
"1" ; width factor
"0" ; obliquing angle
"N" ; text backwards
"N" ; text upside-down
"N" ; Vertical
)
)
 
)



;;TTF
;| ;
LISTE de TTF ;
|;
(defun GEN_TTF_get (/ lsttf)
;;(setq lstttf (vl-registry-descendents "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts" ""))
(setq lstttf
       (mapcar
  'strcase
  (mapcar
    'vl-filename-base
(vl-registry-descendents "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts" ""))
))

(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (TRUETYPE)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (VGA RES)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (ALL RES)" x)
)
     lstttf))
(setq lstttf (mapcar '(lambda (x)
(vl-string-subst "" " (TOUTES RÉSOLUTIONS)" x)
)
     lstttf))
)
;;**********************************************;




;;TEXTSTYLE
;| ;
LISTE de TEXTSTYLE ;
|;
(defun GEN_TEXTSTYLE_get (/ i txtcount)
(setq txtcount (vla-get-TextStyles
(vla-get-activedocument (vlax-get-acad-object))
       )
)
(vl-load-com)
(setq StyleList ())
(vlax-for i txtcount
  (setq StyleList (append StyleList (list (vla-get-name i))))
)
  StyleList
)
;;**********************************************;
« Last Edit: November 25, 2008, 04:44:16 PM by jvillarreal »
Logged

VovKa

  • Water Moccasin
  • Posts: 1629
  • Ukraine
Re: Force Arial Font to Display during grread
« Reply #8 on: November 25, 2008, 04:55:11 PM »
jvillarreal, no need to create new style when working with MTEXT
before
Code: [Select]
           (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1
      (cond
                     ----skipped-----
                 )
)
(cons 7 "ARIAL")
(cons 10 (polar (cadr Input) 0 (/ ViewSize 50.0)))
after
Code: [Select]
           (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1
              (strcat "{\\fArial;"
      (cond
                     ----skipped-----
                 )
                 "}"
               )
)
(cons 10 (polar (cadr Input) 0 (/ ViewSize 50.0)))
Logged

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #9 on: November 25, 2008, 06:17:40 PM »
Vovka,
Thanks for the reply.
Sounds like a simple solution, but i'm getting "; error: syntax error" when placing "{\\fArial;" before the cond function and "}" after as suggested.
Did i miss something?
Logged

T.Willey

  • Needs a day job
  • Posts: 5251
Re: Force Arial Font to Display during grread
« Reply #10 on: November 25, 2008, 07:05:20 PM »
Are you adding the 'strcat'?  That is needed so that the two strings will be brought together.  The one returned by the 'cond' statement, and the one that will add the override of the arial font.
Logged
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #11 on: November 25, 2008, 08:50:59 PM »
The problem was that i copied and pasted the code from my first post and tested Vovka's suggestion before cleaning up the pasted text  :ugly:
It worked great afterwards! Thanks for the mtext lesson Vovka and for making me look at the code again Tim!
Logged

Andrea

  • Water Moccasin
  • Posts: 2372
Re: Force Arial Font to Display during grread
« Reply #12 on: November 26, 2008, 08:46:17 AM »
Quote from: jvillarreal on November 25, 2008, 03:07:40 PM
My textfill var is set to 1..and it turns out your function is using an existing aerial.shx font..

Arial is a TrueType Font (TTF) not a shx.   :wink:

by the way...the Vovka Code is great and the way to go. :kewl:
Logged
Keep smile...

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Force Arial Font to Display during grread
« Reply #13 on: November 26, 2008, 09:31:05 AM »
I'm sure the arial.shx was created by someone here in the company. But doesn't matter..Vovka's code did the trick as well.
Logged

xshrimp

  • Mosquito
  • Posts: 14
Re: Force Arial Font to Display during grread
« Reply #14 on: November 26, 2008, 10:23:09 AM »
« Last Edit: November 26, 2008, 10:30:24 AM by xshrimp »
Logged
abc
Pages: [1] 2  All |   Go Up
« previous next »