矩形拉伸

newer

论坛以前ST写过一个，http://bbs.xdcad.net/thread-672368-1-1.html


这个修改自那个，修改的地方是拉角点的时候，拽动的是顶点，这样更符合需要。

[sell]

(defun c:XDTB_StretchRectang (/ an an1 d d1 dynpt e i inxs lst mat msg
                                my_err near norm1 norm2 p p1 p2 pam ptl pts
                                scl str v v1 v2 vx vy x
                             )
  (defun my_err (msg)
    (princ "\n")
    (princ msg)
    (xdrx_end)
    (xd::doc:command (list ".undo" 1))
    (setq *error* nil)
  )
  (defun callback (dynpt / d d1 scl)
    (setq v (mapcar
              '-
              dynpt
              p
            )
    )
    (setq norm1 (xdrx_vector_perpvector vx)
          norm2 (xdrx_vector_perpvector vy)
          v1 (xdrx_vector_orthoproject v norm1)
          v2 (xdrx_vector_orthoproject v norm2)
    )
    (xdrx_polyline_setpointat e near dynpt)
    (xdrx_polyline_setpointat e (car inxs) (mapcar
                                             '+
                                             p1
                                             v2
                                           )
    )
    (xdrx_polyline_setpointat e (cadr inxs) (mapcar
                                              '+
                                              p2
                                              v1
                                            )
    )
  )
  (defun callback1 (dynpt / d ptl)
    (setq d (apply
              'xdrx_point_dist2line
              (cons dynpt pts)
            )
          ptl (mapcar
                '(lambda (x)
                   (polar x an1 d)
                 )
                pts
              )
    )
    (mapcar
      '(lambda (i x)
         (xdrx_polyline_setpointat e i x)
       )
      lst
      ptl
    )
  )
  (if (and
        (setq e (xdrx_entsel "\n点选多义线<退出>: " '((0 . "lwpolyline"))))
        (xdrx_polyline_compress (car e))
        (XD::Polyline:IsRectang (car e))
      )
    (progn
      (xd::begin)
      (setq *error* my_err)
      (xdrx_sysvar_push '("osmode" 33))
      (setq p (cadr e)
            e (car e)
            pam (xdrx_curve_getparamatpoint e (trans p 1 0))
            pts (xdrx_polyline_getlinesegat e (fix pam))
      )
      (if (<= 0.34 (cadr (xdrx_math_modf pam)) 0.67)
        (progn
          (xdrx_sysvar_push '("orthomode" 1))
          (setq lst (XD::Polyline:SegIndex e (fix pam))
                an (apply
                     'angle
                     pts
                   )
                an1 (- an _pi2)
                str "Callback1"
                p (trans p 1 0)
          )
        )
        (progn
          (xdrx_sysvar_push '("orthomode" 0))
          (setq mat (xdrx_matrix_identity 3)
                near (XD::Polyline:NearIndex e (trans p 1 0))
                p (xdrx_polyline_getpointat e near)
                inxs (xd::polyline:-index+ e near)
                p1 (xdrx_polyline_getpointat e (car inxs))
                p2 (xdrx_polyline_getpointat e (cadr inxs))
                vx (xdrx_vector_normalize (mapcar
                                            '-
                                            p1
                                            p
                                          )
                   )
                vy (xdrx_vector_normalize (mapcar
                                            '-
                                            p2
                                            p
                                          )
                   )
          )
          (setq str "callback")
        )
      )
      (xdrx_pointmonitor str e)
      (getpoint (trans p 0 1))
      (xdrx_pointmonitor)
      (xdrx_sysvar_pop)
      (xd::end)
    )
  )
  (princ)
)

[/sell]

yoyoho

确实是难得好帖啊，顶先

whdong76

啥也不说了，感谢楼主分享哇！

376394482

啥也不说了，感谢楼主分享哇！

forb0217

这个与CAD自带的拉伸方便多了哈。

yanchao316

啥也不说了，感谢楼主分享哇！

ngc

感谢楼主分享，好好学习一下

ck1569

这个可以有，谢谢楼主分享！

香远益清

newer版主实在厉害，高高手啊，在下佩服。建议实现下一个功能：
数据格式如下： *.dat文件，（或者EXCElL表格文件）
点号，X，Y，ΔX（毫米），ΔY（毫米）
根据XY值将点号展会到图纸上，将ΔX，ΔY值标注在对应点上且在相应点上画上两个垂直的箭头
程序以对话框的形式，如箭头大小、长度，注记文字的大小，图层等。这功能市场上太需要了。

九天揽月亮

感谢楼主分享

松树石头哥

感谢楼主分享

shinelo_f619X

学习下。应该有用

LXH刚开始

确实是好东西，功能比自带的好多了。支持楼主。

Ysn1342

好贴，，点赞

松树石头哥