几个实用的电气小软件

leochen

我想编个通过视口看图的程序，但是在反应器中zoom命令没有反应，请大家指点一下。

(defun c:test ()
  (vl-load-com)
  (mlayer "ddview" 　5　nil)
  (setq        a    (getvar "cvport")
        pt1  (getpoint "\n点取矩形左上角点：")
        pt2  (getcorner pt1 "\n点取矩形右下角点：")
        p1   (list (car pt1) (cadr pt1))
        p2   (list (car pt2) (cadr pt1))
        p3   (list (car pt2) (cadr pt2))
        p4   (list (car pt1) (cadr pt2))
        rec1 (mrec p1 p2 p3 p4 "ddview")
        rec1 (entlast)
        pt   (getpoint pt1 "\n输入看图参照点(相对于矩形左上角点)：")
        x    (- (car pt) (car pt1))
        y    (- (cadr pt) (cadr pt1))
        q1   (list (+ (car pt1) x) (+ (cadr pt1) y))
        q2   (list (+ (car pt2) x) (+ (cadr pt1) y))
        q3   (list (+ (car pt2) x) (+ (cadr pt2) y))
        q4   (list (+ (car pt1) x) (+ (cadr pt2) y))
        rec2 (mrec q1 q2 q3 q4 "ddview")
        rec2 (entlast)
  )
  (vl-cmdf "-vports" "2" "v")
  (setq        b    (car (nth 1 (vports)))
        data (list (cons "x" x)
                   (cons "y" y)
                   (cons 111 (dxf rec2 5))
             )
  )
  (setvar "cvport" b)
  (vl-cmdf "zoom" "o" rec2 "")
  (setvar "cvport" a)
  (putdata rec1 "ddview" data)
  (setq        vobj (list (vlax-ename->vla-object rec1))
        vrl  (vlr-pers
               (vlr-object-reactor
                 vobj
                 data
                 '((:vlr-modified . rec-modified))
               )
             )
  )
  (princ)
)


(defun rec-modified (rec1 reactor c /)
  (setq        data (getdata (vlax-vla-object->ename rec1) "ddview")
        rec2 (handent (cdr (nth 2 data)))
        x    (cdr (nth 0 data))
        y    (cdr (nth 1 data))
        ptl  (cdrs 10 (entget (vlax-vla-object->ename rec1)))
        ptl1 (mapcar '(lambda (n) (list (+ (car n) x) (+ (cadr n) y)))
                     ptl
             )
  )
  (entdel rec2)
  (mrec        (nth 0 ptl1)
        (nth 1 ptl1)
        (nth 2 ptl1)
        (nth 3 ptl1)
        "ddview"
  )
  (setq        rec2 (entlast)
        data (list (cons "x" x)
                   (cons "y" y)
                   (cons 111 (dxf rec2 5))
             )
  )
  (setq        a (getvar "cvport")
        b (car (nth 1 (vports)))
  )
  (setvar "cvport" b)
  (vl-cmdf "zoom" "o" rec2 "")
  (setvar "cvport" a)
  (putdata (vlax-vla-object->ename rec1) "ddview" data)
  (princ)
)



(defun mlayer (lname colour print)
  (if (= (tblobjname "LAYER" lname) nil)
    (entmake (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(6 . "CONTINUOUS")
               (cons 62 colour)
               '(70 . 0)
               (cons 2 lname)
               (if print
                 (cons 290 1)
                 (cons 290 0)
               )
             )
    )
  )
  (princ)
)

(defun mrec (pt1 pt2 pt3 pt4 layer / a)
  (setq        a (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            '(67 . 0)
            '(410 . "Model")
            (cons 8 layer)
            '(100 . "AcDbPolyline")
            '(90 . 4)
            '(70 . 1)
            '(43 . 0.0)
            '(38 . 0.0)
            '(39 . 0.0)
            (cons 10 pt1)
            '(40 . 0.0)
            '(41 . 0.0)
            '(42 . 0.0)
            (cons 10 pt2)
            '(40 . 0.0)
            '(41 . 0.0)
            '(42 . 0.0)
            (cons 10 pt3)
            '(40 . 0.0)
            '(41 . 0.0)
            '(42 . 0.0)
            (cons 10 pt4)
            '(40 . 0.0)
            '(41 . 0.0)
            '(42 . 0.0)
            '(210 0.0 0.0 1.0)
          )
  )
  (entmake a)
)

(defun dxf (ent i)
  (if (= (type ent) 'ename)
    (setq ent (entget ent))
  )
  (cdr (assoc i ent))
)

(defun putdata (en key data)
  (setq en (vlax-ename->vla-object en))
  (vlax-ldata-put en key data)
)

(defun getdata (en key)
  (setq en (vlax-ename->vla-object en))
  (vlax-ldata-get en key)
)

(defun cdrs (key lst / pair rtn)
  (while (setq pair (assoc key lst))
    (setq lst (cdr (member pair lst))
          rtn (cons (cdr pair) rtn)
    )
  )
  (reverse rtn)
)