文字拟合lisp

vanowm · 发表于 2022-7-5 13:52:42

非常感谢你。它适用于将justify设置为中间中心的文本。但是，如果将justify设置为其他值，则会将文本移到框外。

Lee Mac · 发表于 2022-7-5 13:57:49

感谢您的反馈，请尝试以下操作：

(defun c:tfit ( / ln pl pt tx )
   (and
       (setq tx (LM:selectifobject "\nSelect text: " "TEXT"))
       (setq pl (LM:selectifobject "\nSelect polyline: " "LWPOLYLINE"))
       (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl)))
             pl (mapcar '(lambda ( x ) (apply 'mapcar (cons x pl))) '(min max))
             tx (entget tx)
       )
       (entmod
           (subst
               (cons 40
                   (*  (cdr (assoc 40 tx)) 0.9 ;; Alter this to suit
                       (apply 'min
                           (mapcar '/
                               (apply 'mapcar (cons '- (reverse pl)))
                               (apply 'mapcar (cons '- (reverse (textbox tx))))
                           )
                       )
                   )
               )
               (assoc 40 tx) tx
           )
       )
       (setq tx (entget (cdr (assoc -1 tx)))
             tb (textbox tx)
             vc (mapcar '- (avgpt pl) (mapcar '+ (cdr (assoc 10 tx)) (avgpt tb)))
       )
       (entmod
           (subst (cons 10 (mapcar '+ (cdr (assoc 10 tx)) vc)) (assoc 10 tx)
               (subst (cons 11 (mapcar '+ (cdr (assoc 11 tx)) vc)) (assoc 11 tx) tx)
           )
       )
   )
   (princ)
)
(defun avgpt ( lst )
   ((lambda ( len ) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list len len))) (length lst))
)
   
;; Select if Object  -  Lee Mac
;; Continuously prompts the user for a selection of a specific object
(defun LM:selectifobject ( msg obj / ent )
   (while
       (progn (setvar 'errno 0) (setq ent (car (entsel msg)))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (= 'ename (type ent))
                   (if (/= obj (cdr (assoc 0 (entget ent))))
                       (princ "\nInvalid Object Selected.")
                   )
               )
           )
       )
   )
   ent
)
(princ)

vanowm · 发表于 2022-7-5 13:59:34

这非常有效！非常感谢你。

现在，我尝试扩展这个例程，使其指向对象内部，而不是选择对象，因此它可以处理重叠的对象。想到命令边界：
然而，由于某些原因，脚本没有超出边界命令，它只是停止。知道为什么吗？

非常感谢。

vanowm · 发表于 2022-7-5 14:01:37

那是一个掌心。。。所有这些命令都在（和…）的内部边界命令返回nil。
这似乎现在起作用了：
如果是tex，则发现一个问题

vanowm · 发表于 2022-7-5 14:06:28

Can anyone help with angled text?

Thank you.

vanowm · 发表于 2022-7-5 14:08:06

I think I fixed it, thanks Lee Mac for bounding box routine:

copy

(DEFUN c:tfit (/ ln pl pt tx)   (AND       (SETQ tx (LM:selectifobject "\nSelect text: " "TEXT"));        (setq pl (LM:selectifobject "\nSelect polyline: " "LWPOLYLINE"))       (SETQ pl (GETPOINT "\nSelect a point: ")       )       (tfit (ENTGET tx) pl)   )   (PRINC))(DEFUN tfit (tx pl / tb vc x)   (SETVAR "cmdecho" 0)   (AND       tx       pl       (NOT (COMMAND "-boundary" pl ""))       (SETQ pl (ENTLAST))       (SETQ pl (MAPCAR 'CDR (VL-REMOVE-IF-NOT '(LAMBDA (x) (= 10 (CAR x))) (ENTGET pl)))             pl (MAPCAR '(LAMBDA (x) (APPLY 'MAPCAR (CONS x pl))) '(MIN MAX))       )       (NOT (COMMAND "_.undo" ""))       (ENTMOD           (SUBST               (CONS 40                     (* (CDR (ASSOC 40 tx))                        0.9 ; Alter this to suit                        (APPLY 'MIN                               (MAPCAR '/                                       (APPLY 'MAPCAR (CONS '- (REVERSE pl)))                                       (APPLY 'MAPCAR (CONS '- (REVERSE (_TEXTBOX tx nil))))                               )                        )                     )               )               (ASSOC 40 tx)               tx           )       )       (SETQ tx  (ENTGET (CDR (ASSOC -1 tx)))             tb  (_TEXTBOX tx nil)             vc  (MAPCAR '- (avgpt pl) (MAPCAR '+ (CDR (ASSOC 10 tx)) (avgpt tb)))             add (MAPCAR '- (CDR (ASSOC 10 tx)) (CAR (_textbox tx T)))       )       (ENTMOD           (SUBST (CONS 10 (MAPCAR '+ (CDR (ASSOC 10 tx)) vc add))                  (ASSOC 10 tx)                  (SUBST (CONS 11 (MAPCAR '+ (CDR (ASSOC 11 tx)) vc add)) (ASSOC 11 tx) tx)           )       )   )   (SETVAR "cmdecho" 1)   (PRINC))(DEFUN avgpt (lst)   (MAPCAR '/ (APPLY 'MAPCAR (CONS '+ lst)) (LIST 2 2)));; Select if Object  -  Lee Mac;; Continuously prompts the user for a selection of a specific object(DEFUN LM:selectifobject (msg obj / ent)   (WHILE       (PROGN (SETVAR 'errno 0)              (SETQ ent (CAR (ENTSEL msg)))              (COND                  ((= 7 (GETVAR 'errno))                   (PRINC "\nMissed, try again.")                  )                  ((= 'ename (TYPE ent))                   (IF (/= obj (CDR (ASSOC 0 (ENTGET ent))))                       (PRINC "\nInvalid Object Selected.")                   )                  )              )       )   )   ent);; Selection Set Bounding Box  -  Lee Mac;; Returns a list of the lower-left and upper-right WCS coordinates of a;; rectangular frame bounding all objects in a supplied selection set.;; s - [sel] Selection set for which to return bounding box(DEFUN _textbox (s coords / a b c m n o ll ur)   (SETQ a nil         b nil         m nil         n nil   )   (SETQ o (VLAX-ENAME->VLA-OBJECT (CDR (ASSOC -1 s))))   (IF (AND o            (VLAX-METHOD-APPLICABLE-P o 'getboundingbox)            (NOT (VL-CATCH-ALL-ERROR-P                     (VL-CATCH-ALL-APPLY 'VLA-GETBOUNDINGBOX (LIST o 'a 'b))                 )            )       )       (SETQ m (CONS (VLAX-SAFEARRAY->LIST a) m)             n (CONS (VLAX-SAFEARRAY->LIST b) n)       )   )   (SETQ c  (MAPCAR '(LAMBDA (a b) (APPLY 'MAPCAR (CONS a b))) '(MIN MAX) (LIST m n))         ll (CAR c)         ur (CADR c)   )   (IF (NOT coords)       (SETQ c (LIST (LIST 0 0 (NTH 2 (CAR c)))                     (LIST (ABS (- (CAR ll) (CAR ur)))                           (ABS (- (CADR ll) (CADR ur)))                           (NTH 2 (CADR c))                     )               )       )   )   c)

muhsinos · 发表于 2022-7-5 14:12:01

Hi There

Is it possible to make Lee`s code for mtexts?

Thanks...

vanowm · 发表于 2022-7-5 14:14:40

All of the sudden the last code I posted above stopped working, it now gets error "divide by zero", pointing to

copy

                               (MAPCAR '/                                       (APPLY 'MAPCAR (CONS '- (REVERSE pl)))                                       (APPLY 'MAPCAR (CONS '- (REVERSE (_TEXTBOX tx nil))))                               )

Any ideas why?

Jef! · 发表于 2022-7-5 14:20:10

divide by 0 error is (drum roll) because you divide by zero!
adding a little surveillance cam like this

copy

                               (MAPCAR '/                                       (setq tmp1 (APPLY 'MAPCAR (CONS '- (REVERSE pl))))                                       (setq tmp2 (APPLY 'MAPCAR (CONS '- (REVERSE (_TEXTBOX tx nil)))))                               )

which after crash help me retrieve tmp1 and tmp2. Here's what is in them
Command: !tmp1
(0.0 0.0 0.0)
Command: !tmp2
(0.729203 0.242907 0.0)
the mapcar divide the 1rst element of tmp1 by the 1rst element of tmp2 (0.0 / 0.729203)
the mapcar then divide the 2nd element of tmp1 by the 2nd element of tmp2 (0.0 / 0.242907)
the mapcar then divide the 3rd element of tmp1 by the 3rd element of tmp2 (0.0 / 0.0). (bombs here...)

I always had that same values in tmp1/tmp2 no matter the position of of the text. After digging out to understand the code, here'S what I found out. The problem is the boundary command. If if fails to create a boundary, entlast will retrieve something else (in my case the text). a pline will have only 2 sets of coords in assoc 10, so tmp1 has 2 elements, so the 3rd element of tmp2, which is 0 is ignored.
ie: (mapcar '/ '(10 10)'(2 2 0)) returns (5 5)
When boundary fails to be created, in my case the text was selected, which has a set of x y z coords. When it happens, here' what is in PL just before you try to mapcar the division
((226.922 97.1085 0.0) (226.922 97.1085 0.0))
What you could do, get/store the entlast before boundary. After boundary, if the "new" entlast is different the one that you stored, proceed, else you know the boundary creation failed, and could prompt a message before quitting.

vanowm · 发表于 2022-7-5 14:21:00

In my case the boundary being created successfully (creates POLYLINE on top of LWPOLYLINE) , it's for some reason coordinates of it in assoc 10 is (0.0 0.0 0.0)
In fact there is no any coordinates available in that boundary polyline:

copy

((-1 . ) (0 . "POLYLINE") (330 . ) (5 . "196") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")(100 . "AcDb2dPolyline") (66 . 1) (10 0.0 0.0 0.0) (70 . 1) (40 . 0.0) (41 .0.0) (210 0.0 0.0 1.0) (71 . 0) (72 . 0) (73 . 0) (74 . 0) (75 . 0))

This used to work flawlessly before, there must be some setting I've changed that broke it...

[编程交流] 文字拟合lisp

发表回复

精选推荐