[编程申请]：谁帮我写一个AUTOlisp程序

sidney2002

本人因为工作关系经常要计算一个值很是浪费时间,谁帮我写一个谢谢!!

是用这个程序 去算这个S值，即加载这个程序后，然后选择要计算

的图案，最后自动算出S

lt_zzy

我给你写了一个程序（LSP），也不知道合不合你的要求，但愿对你有所帮助。
你将程序加载以后，直接输入AA就可以了，如果你问题请与我联系：lt_zzy@sina.com

cssanhui

S=L1/W1+L2/W2？是求两线段的长宽比的和吗？还是求面积的和
S=L1*W1+L2*W2？

zhynt

不知到是什么，如果是面积的话，还有角上的一小块面积没算。

sidney2002

最初由 cssanhui 发布
[B]S=L1/W1+L2/W2？是求两线段的长宽比的和吗？还是求面积的和
S=L1*W1+L2*W2？ [/B]

是长宽比的和！！

lt_zzy

我写给你的程序里面就是你所要求的求长宽比。

sidney2002

但是我不能下载，因为我的爱心币不够，你发到我信箱好吗，谢谢！！

lt_zzy

(defun single_select ( flt flag / a p1 p2 ss ss2 flag2)

(while (not flag2)
(setvar "highlight" 0)
(if (entnext)
    (progn
     (command "_.select" (entnext) "")
     (command "_.undo" "1");clear any selection sets
    );progn then
);if
(setvar "highlight" 1)
(command "_.select" "_si")
(setvar "cmdecho" 1)
(command pause)

(setq ss2 (ssget "p")
       p1 (getvar "lastpoint")
       p1 (trans p1 1 (getvar "viewdir"))
        a (* (getvar "pickbox") (pixel_unit))
       p2 (list (- (car p1) a) (- (cadr p1) a) 0.0)
       p1 (list (+ (car p1) a) (+ (cadr p1) a) 0.0)
       p1 (trans p1 (getvar "viewdir") 1)   
       p2 (trans p2 (getvar "viewdir") 1)   
);setq
(if (and ss2
         (or (setq ss (ssget "p" flt))
             (setq ss (ssget "c" p1 p2 flt))   
         );or
    );and
    (progn
     (setq ss (ssname ss 0))
     (if flag
         (setq flag2 T)
         (progn
          (if (b_layer_locked (cdr (assoc 8 (entget ss))))
              (progn
               (setq flag2 nil)
               (princ "\nThat object is on a locked layer!")
              );progn
              (setq flag2 T);else got something and its on an UN-locked layer
          );if
         );progn else locked layer selection is not allowed
     )
    )
    (progn
     (if ss2
         (princ "\nInvalid selection.")
         (setq flag2 T);they just exited with enter
     )
    )
)
(setvar "cmdecho" 0)
)
ss
)


(defun pixel_unit ( / x y x1 y1)
(setq  y (getvar "viewsize")
       x1 (car (getvar "screensize"))
       y1 (cadr (getvar "screensize"))
        x (* y (/ x1 y1))
)
(max (abs (/ y y1))
      (abs (/ x x1))
)
)



(defun xwb(txt height ptnew / txt_pp sty txt_p height_p ptold )
   (setq txt_pp  '((0 . "TEXT") (67 . 0) (10 1.0 1.0 0.0) (40 . 20.0) (1 . "000") (50 . 0.0) (41 . 0.75) (51 . 0.0) (7 . "STANDARD") (71 . 0) (72 . 0) (73 . 0)))
   (setq sty (getvar "textstyle"))        
   (setq sty (cons 7 sty))
   (setq txt_p (cons 1 txt))
   (setq height_p (cons 40 height))
   (setq txt_pp (subst sty (assoc 7 txt_pp) txt_pp))
   (setq txt_pp (subst height_p (assoc 40 txt_pp) txt_pp))
   (setq txt_pp (subst txt_p (assoc 1 txt_pp) txt_pp))
   (setq ptnew (cons 10 ptnew))
   (setq txt_pp (subst ptnew (assoc 10 txt_pp) txt_pp))
   (entmake txt_pp)                                      
   (princ)
)

(defun c:xwb ()
(xwb txt height ptnew)
(princ))


(defun c:aa()
  (princ "\n请选择L1线:")
  (setq l1 (single_select  '((0 . "LINE")) T))
  (redraw l1 3)
  (princ "\n请选择W1线:")
  (setq w1 (single_select  '((0 . "LINE")) T))
  (redraw w1 3)
  (princ "\n请选择L2线:")
  (setq l2 (single_select  '((0 . "LINE")) T))
  (redraw l2 3)
  (princ "\n请选择W2线:")
  (setq w2 (single_select  '((0 . "LINE")) T))
  (redraw w2 3)
  (setq ll1 (entget l1))
  (setq ll2 (entget l2))
  (setq ww1 (entget w1))
  (setq ww2 (entget w2))
  (setq l1x1 (cadr (assoc 10 ll1)))
  (setq l1y1 (caddr (assoc 10 ll1)))
  (setq l1x2 (cadr (assoc 11 ll1)))
  (setq l1y2 (caddr (assoc 11 ll1)))
  (setq l2x1 (cadr (assoc 10 ll2)))
  (setq l2y1 (caddr (assoc 10 ll2)))
  (setq l2x2 (cadr (assoc 11 ll2)))
  (setq l2y2 (caddr (assoc 11 ll2)))
  (setq w1x1 (cadr (assoc 10 ww1)))
  (setq w1y1 (caddr (assoc 10 ww1)))
  (setq w1x2 (cadr (assoc 11 ww1)))
  (setq w1y2 (caddr (assoc 11 ww1)))
  (setq w2x1 (cadr (assoc 10 ww2)))
  (setq w2y1 (caddr (assoc 10 ww2)))
  (setq w2x2 (cadr (assoc 11 ww2)))
  (setq w2y2 (caddr (assoc 11 ww2)))
  (setq disl1 (sqrt (+ (* (- l1x1 l1x2) (- l1x1 l1x2)) (* (- l1y1 l1y2) (- l1y1 l1y2)))))
  (setq disl2 (sqrt (+ (* (- l2x1 l2x2) (- l2x1 l2x2)) (* (- l2y1 l2y2) (- l2y1 l2y2)))))
  (setq disw1 (sqrt (+ (* (- w1x1 w1x2) (- w1x1 w1x2)) (* (- w1y1 w1y2) (- w1y1 w1y2)))))
  (setq disw2 (sqrt (+ (* (- w2x1 w2x2) (- w2x1 w2x2)) (* (- w2y1 w2y2) (- w2y1 w2y2)))))
  (setq sstr (+ (/ disl1 disw1) (/ disl2 disw2)))
  (setq sstr (rtos sstr 2 3))
  (setq sstr (strcat "S=" sstr))
  (setq spt (getpoint"\n请选择起点:"))
  (setq height (getreal "\n请输入文本高度<2>:"))
  (if (null height)
    (progn
      (setq height 2)
    )
  )
  (xwb sstr height spt)
  (redraw l1 4)
  (redraw l2 4)
  (redraw w1 4)
  (redraw w2 4)
  (princ)
)

sidney2002

请问它提示输入ARX档案的名称，应该输入啥名字啊？

zhynt

没有啊？没有什么提示要输入什么arx档啊，不过我怎么觉得不需要这么复杂啊。

aeo

(defun c:lw( / len s)
(defun len(e)(distance(cdr(assoc 10(entget e)))(cdr(assoc 11(entget e)))))
(setq s(+(/(len(car (entsel)))(len(car (entsel))))(/(len(car (entsel)))(len(car (entsel)))) ))
(princ s)
)

lt_zzy

sidney2002 ：
我将程序上面的汉字改成了英语，估计这下应该没有问题了。
你试试吧。

(defun single_select ( flt flag / a p1 p2 ss ss2 flag2)

(while (not flag2)
(setvar "highlight" 0)
(if (entnext)
    (progn
     (command "_.select" (entnext) "")
     (command "_.undo" "1");clear any selection sets
    );progn then
);if
(setvar "highlight" 1)
(command "_.select" "_si")
(setvar "cmdecho" 1)
(command pause)

(setq ss2 (ssget "p")
       p1 (getvar "lastpoint")
       p1 (trans p1 1 (getvar "viewdir"))
        a (* (getvar "pickbox") (pixel_unit))
       p2 (list (- (car p1) a) (- (cadr p1) a) 0.0)
       p1 (list (+ (car p1) a) (+ (cadr p1) a) 0.0)
       p1 (trans p1 (getvar "viewdir") 1)   
       p2 (trans p2 (getvar "viewdir") 1)   
);setq
(if (and ss2
         (or (setq ss (ssget "p" flt))
             (setq ss (ssget "c" p1 p2 flt))   
         );or
    );and
    (progn
     (setq ss (ssname ss 0))
     (if flag
         (setq flag2 T)
         (progn
          (if (b_layer_locked (cdr (assoc 8 (entget ss))))
              (progn
               (setq flag2 nil)
               (princ "\nThat object is on a locked layer!")
              );progn
              (setq flag2 T);else got something and its on an UN-locked layer
          );if
         );progn else locked layer selection is not allowed
     )
    )
    (progn
     (if ss2
         (princ "\nInvalid selection.")
         (setq flag2 T);they just exited with enter
     )
    )
)
(setvar "cmdecho" 0)
)
ss
)


(defun pixel_unit ( / x y x1 y1)
(setq  y (getvar "viewsize")
       x1 (car (getvar "screensize"))
       y1 (cadr (getvar "screensize"))
        x (* y (/ x1 y1))
)
(max (abs (/ y y1))
      (abs (/ x x1))
)
)



(defun xwb(txt height ptnew / txt_pp sty txt_p height_p ptold )
   (setq txt_pp  '((0 . "TEXT") (67 . 0) (10 1.0 1.0 0.0) (40 . 20.0) (1 .

"000") (50 . 0.0) (41 . 0.75) (51 . 0.0) (7 . "STANDARD") (71 . 0) (72 . 0)

(73 . 0)))
   (setq sty (getvar "textstyle"))        
   (setq sty (cons 7 sty))
   (setq txt_p (cons 1 txt))
   (setq height_p (cons 40 height))
   (setq txt_pp (subst sty (assoc 7 txt_pp) txt_pp))
   (setq txt_pp (subst height_p (assoc 40 txt_pp) txt_pp))
   (setq txt_pp (subst txt_p (assoc 1 txt_pp) txt_pp))
   (setq ptnew (cons 10 ptnew))
   (setq txt_pp (subst ptnew (assoc 10 txt_pp) txt_pp))
   (entmake txt_pp)                                      
   (princ)
)

(defun c:xwb ()
(xwb txt height ptnew)
(princ))


(defun c:aa()
  (princ "\nSelect the L1 line:")
  (setq l1 (single_select  '((0 . "LINE")) T))
  (redraw l1 3)
  (princ "\nSelect the W1 line:")
  (setq w1 (single_select  '((0 . "LINE")) T))
  (redraw w1 3)
  (princ "\nSelect the L2 line:")
  (setq l2 (single_select  '((0 . "LINE")) T))
  (redraw l2 3)
  (princ "\nSelect the W2 line:")
  (setq w2 (single_select  '((0 . "LINE")) T))
  (redraw w2 3)
  (setq ll1 (entget l1))
  (setq ll2 (entget l2))
  (setq ww1 (entget w1))
  (setq ww2 (entget w2))
  (setq l1x1 (cadr (assoc 10 ll1)))
  (setq l1y1 (caddr (assoc 10 ll1)))
  (setq l1x2 (cadr (assoc 11 ll1)))
  (setq l1y2 (caddr (assoc 11 ll1)))
  (setq l2x1 (cadr (assoc 10 ll2)))
  (setq l2y1 (caddr (assoc 10 ll2)))
  (setq l2x2 (cadr (assoc 11 ll2)))
  (setq l2y2 (caddr (assoc 11 ll2)))
  (setq w1x1 (cadr (assoc 10 ww1)))
  (setq w1y1 (caddr (assoc 10 ww1)))
  (setq w1x2 (cadr (assoc 11 ww1)))
  (setq w1y2 (caddr (assoc 11 ww1)))
  (setq w2x1 (cadr (assoc 10 ww2)))
  (setq w2y1 (caddr (assoc 10 ww2)))
  (setq w2x2 (cadr (assoc 11 ww2)))
  (setq w2y2 (caddr (assoc 11 ww2)))
  (setq disl1 (sqrt (+ (* (- l1x1 l1x2) (- l1x1 l1x2)) (* (- l1y1 l1y2) (-

l1y1 l1y2)))))
  (setq disl2 (sqrt (+ (* (- l2x1 l2x2) (- l2x1 l2x2)) (* (- l2y1 l2y2) (-

l2y1 l2y2)))))
  (setq disw1 (sqrt (+ (* (- w1x1 w1x2) (- w1x1 w1x2)) (* (- w1y1 w1y2) (-

w1y1 w1y2)))))
  (setq disw2 (sqrt (+ (* (- w2x1 w2x2) (- w2x1 w2x2)) (* (- w2y1 w2y2) (-

w2y1 w2y2)))))
  (setq sstr (+ (/ disl1 disw1) (/ disl2 disw2)))
  (setq sstr (rtos sstr 2 3))
  (setq sstr (strcat "S=" sstr))
  (setq spt (getpoint"\nText start point:"))
  (setq height (getdist spt "\nText height<2>:"))
  (if (null height)
    (progn
      (setq height 2)
    )
  )
  (xwb sstr height spt)
  (redraw l1 4)
  (redraw l2 4)
  (redraw w1 4)
  (redraw w2 4)
  (princ)
)

cssanhui

最初由 aeo 发布
[B](defun c:lw( / len s)
(defun len(e)(distance(cdr(assoc 10(entget e)))(cdr(assoc 11(entget e)))))
(setq s(+(/(len(car (entsel)))(len(car (entsel))))(/(len(car (entsel)))(len(car (entsel)))) ))
(p... [/B]

在确保图形是固定的模式下，我个人非常欣赏这个程序。简单、明了。
建议斑竹加分。

sidney2002

我的结果是非法的,...

可其它AUOTLISP可以用啊,帮忙分析一下,,,,,,

sidney2002

最初由 sidney2002 发布
[B]我的结果是非法的,...LW在我里面是定义线宽和线型的,,所以我改成LWO了

可其它AUOTLISP可以用啊,帮忙分析一下,,,,,, [/B]