[原创]：簡易線性尺寸驅動程序(支持復線與線）

舟自横

一個簡易的線性驅動程序﹔﹔﹔源碼共享
看到前面有讨论过但是好象没有程序...试写一个简单的..希望大家不要见笑...
剛剛寫好歡迎測試。。。支持線與復線..可支持有旋轉角度線性尺寸
發現有BUG等修改后在上傳
[php]
(defun c:hy0032(/ olderror eno en obj ent p1 p10 p2 long ago
                key px po1 po2 ang1 newp ang2 dis ss ss1 ss2);;LINE LWPOLYLINE ARC ;;;尺寸驅動
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (SETQ olderror *error*)
  (defun *error*(msg) (setq *error* olderror) (princ) (princ))
  (setq eno (entsel "\n請選擇需要驅動的線性尺寸:"))
  (while (not (or eno (member '(100 . "AcDbRotatedDimension") (entget(car eno)))
                  (member '(100 . "AcDbAlignedDimension") (entget(car eno)))))
    (setq eno (entsel "\n你選的不是線性尺寸﹐請重新選擇需要驅動的線性尺寸<或ESC退出>:")))
  (setq en (car eno) px (cadr eno)
        obj (vlax-ename->vla-object en)
        ent (entget en)
        p1 (cdr (assoc 13 ent))
        p10 (cdr (assoc 10 ent))
        p2 (cdr (assoc 14 ent))
        )
  (REDRAW EN 3)
  (INITGET  "S D")
  (setq key (getkword "\n雙向驅動(D)/單向驅動<--前面點選尺寸之方向-->(S <DEFAULT>):"))
  (if (not key) (setq key "S"))
  (setq long (cdr (assoc 42 ent)))
  (setq ago (getreal (strcat "\n請輸入變更后尺寸<" (rtos long 2 5) ">:")))
  (if (= nil ago) (setq ago long))
  (setq dis (-  ago long))
  (if (= key "S") (PROGN
  (if (< (distance px p1) (distance px p2)) (progn (setq po1 p1
                                                  po2 p2
                                                  ANG1 (+ (angle p2 p10) (* 0.5 pi))
                                                  newp (polar po1 ang1 dis))
                                                  (entmod
                                                    (subst (cons 13 newp) (assoc 13 ent) ent)
                                                    )
                                              )
    (progn
                                            (setq po1 p2
                                                  po2 p1
                                                  ANG1 (- (angle p2 p10) (* 0.5 pi))
                                                  newp (polar po1 ang1 dis)
                                                  )
      (entmod
                                                    (subst (cons 14 newp) (assoc 14 ent) ent)
                                                    )
    )
    )
  (SETQ ss (ssget "c" (polar po1 (* 0.25 pi) 0.1) (polar po1 (* 1.25 pi) 0.1)
        (list '(0 . "LINE,LWPOLYLINE"))))
  (setq ss (ss->list ss))
  (foreach item ss (cond ((= "LINE" (cdr(assoc 0 (entget item)))) (hy0032_line po1 item ang1 DIS))
                         ((= "LWPOLYLINE" (cdr(assoc 0 (entget item)))) (hy0032_LWPOLYLINE po1 item ang1 DIS))
                         )
    )
  )
    (progn (SETQ ss1 (ssget "c" (polar p1 (* 0.25 pi) 0.1) (polar p1 (* 1.25 pi) 0.1)
        (list '(0 . "LINE,LWPOLYLINE"))))
           (SETQ ss2 (ssget "c" (polar p2 (* 0.25 pi) 0.1) (polar p2 (* 1.25 pi) 0.1)
        (list '(0 . "LINE,LWPOLYLINE"))))
        (setq ss1 (ss->list ss1))
        (setq ss2 (ss->list ss2))
        (setq ang2 (+ (angle p2 p10) (* 0.5 pi)))
        (setq newp (polar p1 ang2 (/ dis 2)))
        (entmod (subst (cons 13 newp) (assoc 13 ent) ent))
        (foreach item ss1 (cond ((= "LINE" (cdr(assoc 0 (entget item)))) (hy0032_line p1 item ang2 (/ DIS 2)))
                         ((= "LWPOLYLINE" (cdr(assoc 0 (entget item)))) (hy0032_LWPOLYLINE p1 item ang2 (/ DIS 2)))
                         ))
        (setq ang2 (- (angle p2 p10) (* 0.5 pi)))
        (setq newp (polar p2 ang2 (/ dis 2)))
        (setq ent (entget en))
        (entmod (subst (cons 14 newp) (assoc 14 ent) ent))
        (foreach item ss2 (cond ((= "LINE" (cdr(assoc 0 (entget item)))) (hy0032_line p2 item ang2 (/ DIS 2)))
                         ((= "LWPOLYLINE" (cdr(assoc 0 (entget item)))) (hy0032_LWPOLYLINE p2 item ang2 (/ DIS 2)))
                         ))
   
    )
    )
  (setq *error* olderror)
  (prompt "\n尺寸驅動成功! THANK YOU FOR USING!----WRITTING BY XING-----" )
  (prin1)
  )
(defun hy-DblList->VariantArray (nList / ArraySpace sArray)
  ; allocate space for an array of 2d points stored as doubles
  (setq ArraySpace
         (vlax-Make-SafeArray
           vlax-vbDouble        ; element type
           (cons 0
             (- (length nList) 1)
           )
         )
  )
  (setq sArray (vlax-SafeArray-Fill ArraySpace nList))

  ; return array variant
  (vlax-Make-Variant sArray)
)
                         
(defun hy0032_line (po un ang dis / newpa uno)
  (setq newpa (polar po ang dis))
  (setq uno (vlax-ename->vla-object un))
  (cond ((equal po (vlax-safearray->list
                      (vlax-variant-value
                       (vla-get-startpoint uno))) 1e-6)
         (vla-put-startpoint uno(hy-DblList->VariantArray newpa))
         )
        ((equal po (vlax-safearray->list(vlax-variant-value
                       (vla-get-endpoint uno))) 1e-6)
         (vla-put-endpoint uno (hy-DblList->VariantArray newpa))
         )
        )
  )
(defun hy0032_LWPOLYLINE(po un ang dis / newpa uno param)
  (setq newpa (polar po ang dis))
  (setq uno (vlax-ename->vla-object un)
        Coordinates (vlax-safearray->list(vlax-variant-value(vla-get-Coordinates uno))))
  (if (vl-some  '(lambda(x) (equal po (hy-2d->3d x) 1e-6)) (hy_ocom Coordinates 2))
    (progn (setq param (vlax-curve-getparamatpoint uno po))
      (vla-put-Coordinate uno param (hy-DblList->VariantArray (list (car newp) (cadr newpa))))
      )
    )
  )
(defun ss->list(ss / i sslist);;;將選擇集內容列表(as ap-sslist)
  (if ss (progn
  (setq i 0)
  (setq sslist nil)
  (repeat (sslength ss)
    (setq sslist (cons (ssname ss i) sslist))
    (setq i (1+ i))
    )
  (reverse sslist)
  )
    )
  )
(defun hy-2d->3d(point);;;;;;;2D TO 3D
  (vlax-safearray->list
    (vlax-variant-value
      (vlax-3d-point point))
    )
  )
[/php]
測試(defun c:tt() (c:hy0032))
附效果圖

lff763

希望弧长也能驱动

lff763

希望能有这样的效果，弧长也可驱动