cad 数值自动计算

zhanghuohuo

以下是一个数值计算插件，修改数值能自动更新结果。

cad2008中能够使用。在cad2016中 调用VBS的公用执行函数 失败（代码表黑的部分）。
请问大神怎么修改！！

(defun c:tt ();;;表达式计算
;;;选择要计算的表达式:
  (vl-load-com)
  (prompt "\n 选择要计算的表达式:")
  (if (setq ss (ssget (list (cons 0 "TEXT"))))
    (repeat (setq k (sslength ss))
      (setq ent (ssname ss (setq k (1- k))))
      (setq jsjg (xlr_get_cal (setq tx (xlr_dxf 1 ent))))
      (setq pt (nth 8 (xlr_get_box9 ent)))
      (setvar "textstyle" (xlr_dxf 7 ent ))
      (setvar "textsize" (xlr_dxf 40 ent ))
      (xlr_put_text (strcat "=" (rtos jsjg 2 2)) pt 0 0 "JG" 3)
      (setq ent1 (entlast))
      (xlr_fyq_text ent  ent1)
    )
  )
)

(defun xlr_call        (@string /)
  (vl-load-com)
  (if (member "geomcal.arx" (arx))
    nil
    (arxload "geomcal.arx" nil)
  )
  (vl-catch-all-apply 'c:cal (list @string))
)

;;;[功能] 调用VBS的公用执行函数
(defun xlr_wscriptPublic (str)
  (or *wscript*
      (setq *wscript* (vlax-create-object "ScriptControl"))
  )
  (vlax-put *wscript* 'language "vbs")
  (vlax-invoke-method *wscript* 'ExecuteStatement str)
  (vlax-invoke-method *wscript* 'eval "ret")
)

(defun xlr_get_cal (express)  ;;表达式计算
  (xlr_wscriptPublic (strcat "dim ret \n ret=" express))
)

(defun xlr_put_text (text1 putpoint zm72 zm73 layer_1 textcolor / )
  (setq @enttext nil)
  (if (= (type text1) 'STR)
    (progn
      (entmake
        (append
          (list        (cons 0 "TEXT")
                (cons 100 "AcDbEntity")
                (cons 100 "AcDbText")
                (cons 8 layer_1)
                (cons 62 textcolor)
          )
          (list        (cons 10 putpoint)
                (cons 11 putpoint)
                (cons 71 0)
                (cons 72 zm72)
                (cons 73 zm73)
                (cons 40 (getvar "TEXTSIZE"))
                (cons 1 text1)
                (cons 7 (getvar "TEXTSTYLE"))
          )
        )
      )
      (setq @enttext (entlast))
    )
    )
  @enttext
  )


;;;(xlr_get_box9 对象或选择集)对象外框9格点
(defun xlr_get_box9(@ENAME / @BOX1 @PT1 @PT3 @PT2 @PT7 @PT9 @PT4 @PT5 @PT6)
  (setq @box1 (xlr_get_box @ename))
  (setq @pt1 (list (car (car @box1))(cadr (cadr @box1)) 0.0 ))
  (setq @pt3 (list (car (cadr @box1))(cadr (cadr @box1)) 0.0))
  (setq @pt2 (xlr_mid @pt1 @pt3))
  (setq @pt7 (list (car (car @box1))(cadr (car @box1)) 0.0))
  (setq @pt9 (list (car (cadr @box1))(cadr (car @box1)) 0.0))
  (setq @pt8 (xlr_mid @pt7 @pt9))
  (setq @pt4 (xlr_mid @pt1 @pt7))
  (setq @pt6 (xlr_mid @pt3 @pt9))
  (setq @pt5 (xlr_mid @pt4 @pt6))
  (list @pt1 @pt2 @pt3 @pt4 @pt5 @pt6 @pt7 @pt8 @pt9)
  )



(defun xlr_mid ( a b )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
)



(defun xlr_get_box (@enmae / i l1 l2 ll ur);;;
  (cond
    ((= (type @enmae) 'PICKSET)
     (repeat (setq i (sslength @enmae))
       (vla-getboundingbox
         (vlax-ename->vla-object (ssname @enmae (setq i (1- i))))
         'll
         'ur
       )
       (setq l1        (cons (vlax-safearray->list ll) l1)
             l2        (cons (vlax-safearray->list ur) l2)
       )
     )
    )
    ((= (type @enmae) 'ENAME)
     (vla-getboundingbox
         (vlax-ename->vla-object @enmae)
         'll
         'ur
       )
       (setq l1        (cons (vlax-safearray->list ll) l1)
             l2        (cons (vlax-safearray->list ur) l2)
       )
    )
  )

  (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
          '(min max)
          (list l1 l2)
  )
)
(defun px (X)
    (vl-sort  X
             (function (lambda (e1 e2)
                         (< (car e1) (car e2)) ) ) )
)


(defun xlr_fyq_text (@ent1 @ent2 /)
  (setq @VC (vlax-ename->vla-object @ent1))
  (setq @EH1 (cdr (assoc 5 (entget @ent2))))
  (setq @EH_L (list @EH1))
  (setq @VC_L (list @VC))
  (vlr-pers (vlr-object-reactor
              @VC_L
              @EH_L
              '((:vlr-modified . xlr_fyq_textchange))
            )
  )
;;;  (vlr-pers(vlr-object-reactor vc nil'((:vlr-modified . show))))
  (princ)
)

(defun xlr_dxf (IT ename)
  (cdr (assoc IT (entget ename)))
)

(defun xlr_fyq_textchange (NOTIFIER-OBJECT REACTOR-OBJECT PARAMETER-LIST /)
  (setq @EC (vlax-vla-object->ename NOTIFIER-OBJECT))
  (setq @EC_L (entget @EC))
  (setq @ent3 (vlax-vla-object->ename NOTIFIER-OBJECT ))
  (setq @kj (rtos (xlr_get_cal (xlr_dxf 1 (vlax-vla-object->ename NOTIFIER-OBJECT ))) 2 2))
  (setq @tyd (nth 8 (xlr_get_box9 @ent3)))
  (setq @EH_L (vlr-data reactor-object))
  (setq @E1_L (vlax-ename->vla-object (handent (car @EH_L))))
  (vla-put-textstring @E1_L (strcat "=" @kj))
  (vla-put-InsertionPoint @E1_L (vlax-3d-point @tyd))
  (princ)
)

Kye

解压缩后，安装试试

paulpipi

flfcegu168

达人给你点赞