Topic: Dictionary storage (list) question

[T.Willey]

I have a list that looks like

Code: [Select]

(("i" . 0.380952) ("1" . 0.761905) ("S" . 0.952381) ("F" . 0.857143) ("D" . 1.0) ("A" . 1.04762))And I want to store it in a dictionary.  I'm not very familiar with dictionaries, and was wondering if/how I could store the list so that I can grab it by the letter?  This is in conjunction with my other thread about true spacing of letters per fonts.  I want to store the information within a dictionary within the drawing, so that I don't have to build a list each time the drawing is opened.

My first thought was making a master dictionary, and then having dictionaries with it, named per font name, with xrecords named as the character and the value being the width of the character when the text height is 1 and the width is 1.

Here is the code that I have come up with with the great idea of 'SomeCallMeDave' here.

Code: [Select]

(defun FontLetterWidth (Doc TextObj / MdSpc StyCol Sty FontName DictCol DictObj cnt CurLtr tempText ll ur Dist
                                      FontWidthList WidthList StyName String TextWd TextHt StyDictObj)

(setq StyName (vla-get-StyleName TextObj))
(setq String (vla-get-TextString TextObj))
(setq TextWd (vla-get-ScaleFactor TextObj))
(setq TextHt (vla-get-Height TextObj))
(setq MdSpc (vla-get-ModelSpace Doc))
(setq StyCol (vla-get-TextStyles Doc))
(setq Sty (vla-Item StyCol StyName))
(setq FontName
 (if (findfile (vla-get-fontFile Sty))
  (vl-filename-base (vla-get-fontFile Sty))
  (vl-filename-base (getvar "fontalt"))
 )
)
(setq DictCol (vla-get-Dictionaries Doc))
(if (vl-catch-all-error-p (setq DictObj (vl-catch-all-apply 'vla-Item (list DictCol "MyFontWidthDict"))))
 (setq DictObj (vla-Add DictCol "MyFontWidthDict"))
)
;(if (vl-catch-all-error-p (setq StyDictObj (vl-catch-all-apply 'vla-Item (list DictObj StyName))))
; (setq StyDictObj (vla-Add DictObj StyName))
;)
(setq cnt 1)
(repeat (strlen String)
 (setq CurLtr (substr String cnt 1))
 (if (not (assoc CurLtr FontWidthList))
  (progn
   (setq tempText (vlax-invoke MdSpc 'AddText CurLtr '(0.0 0.0 0.0) 1.0))
   (vla-put-Height tempText 1.0)
   (vla-GetBoundingBox tempText 'll 'ur)
   (setq ll (safearray-value ll))
   (setq ur (safearray-value ur))
   (setq Dist (distance (cons (car ll) (cdr ur)) ur))
   (vla-put-TextString tempText (strcat CurLtr CurLtr))
   (vla-GetBoundingBox tempText 'll 'ur)
   (setq ll (safearray-value ll))
   (setq ur (safearray-value ur))
   (setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
   (setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
   (vla-Delete tempText)
  )
 )
 (setq WidthList (cons (cdr (assoc CurLtr FontWidthList)) WidthList))
 (setq cnt (1+ cnt))
)
(reverse WidthList)
)
Tested with this code

Code: [Select]

(defun c:TestTextDraw (/ ActDoc Sel Obj ll ur Ht)

(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq Sel (entsel "\n Select text object: "))
(setq Obj (vlax-ename->vla-object (car Sel)))
(vla-GetBoundingBox Obj 'll 'ur)
(setq ll (safearray-value ll))
(setq Ht (vla-get-Height Obj))  (grdraw (polar ll (DTR 270) (* Ht 0.25)) (polar ll (DTR 90) (+ Ht (* Ht 0.25))) 1 1)
(foreach i (FontLetterWidth ActDoc Obj)
 (setq ll (polar ll 0.0 i))
 (grdraw (polar ll (DTR 270) (* Ht 0.25)) (polar ll (DTR 90) (+ Ht (* Ht 0.25))) 1 1)
)
)
Was able to produce the attached image, which is correct.

Thanks in advance.

Edit: Commented out the part of the code where it tries to add a dictionary to a dictionary; will error.

[CAB]

That subroutine is pretty fast. Do you really need to store the data.

Still have some gremlins in there though.

[T.Willey]

That subroutine is pretty fast. Do you really need to store the data.

I guess if I see any speed problems then I can see about putting the information into dictionaries.

Still have some gremlins in there though.

I see what you mean.  It is the spaces; they are getting a width value of 0.0 I will fix that.

Thanks for trying it out Alan.  I will post the updated one today sometime.

[T.Willey]

Here is the updated code to work correctly with spaces.

Code: [Select]

(defun FontLetterWidth (Doc TextObj / MdSpc StyCol Sty FontName DictCol DictObj cnt CurLtr tempText ll ur Dist
                                      FontWidthList WidthList StyName String TextWd TextHt StyDictObj)

(setq StyName (vla-get-StyleName TextObj))
(setq String (vla-get-TextString TextObj))
(setq TextWd (vla-get-ScaleFactor TextObj))
(setq TextHt (vla-get-Height TextObj))
(setq MdSpc (vla-get-ModelSpace Doc))
(setq StyCol (vla-get-TextStyles Doc))
(setq Sty (vla-Item StyCol StyName))
(setq FontName
 (if (findfile (vla-get-fontFile Sty))
  (vl-filename-base (vla-get-fontFile Sty))
  (vl-filename-base (getvar "fontalt"))
 )
)
(setq DictCol (vla-get-Dictionaries Doc))
(if (vl-catch-all-error-p (setq DictObj (vl-catch-all-apply 'vla-Item (list DictCol "MyFontWidthDict"))))
 (setq DictObj (vla-Add DictCol "MyFontWidthDict"))
)
;(if (vl-catch-all-error-p (setq StyDictObj (vl-catch-all-apply 'vla-Item (list DictObj StyName))))
; (setq StyDictObj (vla-Add DictObj StyName))
;)
(setq cnt 1)
(repeat (strlen String)
 (setq CurLtr (substr String cnt 1))
 (if (not (assoc CurLtr FontWidthList))
  (progn
   (if (= CurLtr " ")
    (progn
     (setq tempText (vlax-invoke MdSpc 'AddText "AA" '(0.0 0.0 0.0) 1.0))
     (vla-put-Height tempText 1.0)
     (vla-put-ScaleFactor tempText 1.0)
     (vla-put-StyleName tempText StyName)
     (vla-GetBoundingBox tempText 'll 'ur)
     (setq ll (safearray-value ll))
     (setq ur (safearray-value ur))
     (setq Dist (distance (cons (car ll) (cdr ur)) ur))
     (vla-put-TextString tempText (strcat "A" CurLtr "A"))
     (vla-GetBoundingBox tempText 'll 'ur)
     (setq ll (safearray-value ll))
     (setq ur (safearray-value ur))
     (setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
     (setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
     (vla-Delete tempText)
    )
    (progn
     (setq tempText (vlax-invoke MdSpc 'AddText CurLtr '(0.0 0.0 0.0) 1.0))
     (vla-put-Height tempText 1.0)
     (vla-put-ScaleFactor tempText 1.0)
     (vla-put-StyleName tempText StyName)
     (vla-GetBoundingBox tempText 'll 'ur)
     (setq ll (safearray-value ll))
     (setq ur (safearray-value ur))
     (setq Dist (distance (cons (car ll) (cdr ur)) ur))
     (vla-put-TextString tempText (strcat CurLtr CurLtr))
     (vla-GetBoundingBox tempText 'll 'ur)
     (setq ll (safearray-value ll))
     (setq ur (safearray-value ur))
     (setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
     (setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
     (vla-Delete tempText)
    )
   )
  )
 )
 (setq WidthList (cons (cdr (assoc CurLtr FontWidthList)) WidthList))
 (setq cnt (1+ cnt))
)
(reverse WidthList)
)

The next part is to code for the '%%' stuff, so one can get a true string length shown of the text object.