[求助]哪位老大有文字拟合的lisp程序啊

xiaofei_00

哪位老大有文字拟合的lisp程序啊？就是可以随意改变文字宽度的，原来的AutoCAD14汉化包里有这个附加功能，可现在的高版本CAD没有这样的补丁了，最好有源码。

小弟急等用。

ZZXXQQ

游客，本帖隐藏的内容需要发帖数高于 7 才可浏览，你当前发帖数只有 0

xiaofei_00

非常感谢版主的帮助，但实在不好意思，我要的不是这个。请版主帮忙看看下边这段程序，这个就是我所说的功能，一般情况下是可以运行的，但有的时候提示错误 错误类型 "type_0" ,不知道什么原因,这是原R14汉化软件里的一段程序。

(Defun c:textfit (/    setsnapang      arg      LL-xyz   UR-x
    LL-y    LR-xy    ename    TextEnt  NewEnd   TMP
    START    NewPt    Val      LTC_%
   )
 (progn
 (defun setsnapang (arg /)
    (setvar "snapang" (angtof (angtos (cdr (assoc 50 arg)) 0 8) 0 ))
  );end defun setsnapang
  (Defun LL-xyz (arg)                             ;Lower Left xyz coord
     (CAR (TextBox arg))
  )
  (Defun UR-x (arg)                               ;Upper Right x coord
     (CAADR (TextBox arg))
  )
  (Defun LL-y (arg)                               ;Lower left y coord
     (CADAR (TextBox arg))
  )
  (Defun LR-xy (arg)                              ;Lower right xy coord
     (List (UR-x arg) (LL-y arg))
  )
  (Setq
      ename   (CAR
       (EntSel
  "\n选择文字 伸展/收缩:"
       )
     )

    Textent (If ename
       (EntGet ename)
     )
  )

  (If (= (CDR (Assoc 0 textent)) "TEXT")
    (Progn
      (initget 0 "Start")
      (Setq
 NewEnd (Distance
   (LR-xy Textent)
   (LL-xyz Textent)
        )
      )
      (setsnapang Textent)  ;set snap along text entity
      (setvar "ORTHOMODE" 1)  ;drag along the text
      (setq
 TMP (getpoint (cdr (assoc 10 Textent))
        "\n起始点/<选择新结束点>: "
     )
      )
      ;(setvar "snapang" 0)
      (cond
 ((= (type TMP) 'STR)
  ;;new starting point to be selected
  (setq Start (getpoint "\n选择新起始点: "))
  (if Start
    (progn
      (command "_UCS" "_E" (cdr (assoc -1 textent)))
      (setvar "ORTHOMODE" 1)
      (setq NewPt
      (if Start
        (getpoint (trans Start 0 1) "结束点: ")
        nil
      )
      )
      (if NewPt
        (setq NewPt (trans NewPt 1 0))
      )
      (setvar "ORTHOMODE" 0)
      (command "_UCS" "_W")
    )
  )
 )
 ((not (null TMP))
  ;;new ending point selected

  (setq Start (cdr (assoc 10 Textent))
        NewPt TMP
  )
 )
 (t
  (setq Start nil
        NewPt nil
  )
 )
      )
      (if (and Start NewPt)
 (progn
   (setq Val (Assoc 41 Textent)
  ;;current width factor
  Val (if Val
     (cdr Val)
     1.0
   )

  LTC_%
   (*
     (/
       (Distance Start NewPt)
       NewEnd
     )
     Val
   )
  textent (Subst (cons 41 LTC_%)
          (assoc 41 textent)
          textent
   )
  textent (subst (cons 10 Start)
          (assoc 10 textent)
          textent
   )
  textent (subst (cons 11 NewPt)
          (assoc 11 textent)
          textent
   )
   )
   (EntMod textent)
   (EntUpd (cdr (assoc -1 textent)))
 )
      )
      ;;end of points check
    )))) ;end defun

xiaofei_00

请高手帮我看看上边的程序啊，错误在哪里啊？？

ZZXXQQ

在2004中未见错误。