简单的投影程序

菜卷鱼 · 发表于 2014-1-10 09:58:02

本帖最后由菜卷鱼于 2015-12-11 08:46 编辑

多段线投影的程序论坛已经有了http://bbs.mjtd.com/forum.php?mod=viewthread&tid=107683
因为程序是很久以前写的，结构比较冗杂，没有花时间去重写。
2015年8月18号更新，目前支持直线、圆、圆弧、多段线，并加快了反应速度。
内容回复可见，不想回复的直接下载附件吧。

(defun c:pp ( )
(princ "\n简单投影程序，制作BY菜卷鱼")
(setq pi2 (/ pi 2))
(setq 3pi2 (/ (* 3 pi) 2))
(setq les (ssget '((0 . "LINE,CIRCLE,ARC")
(-4 . "<NOT")
(8 . "中心线")
(-4 . "NOT>")
)
)
)
(setq i 0)
(setq pltlr nil)
(setq pltud nil)
(setq clt nil)
(setq plt nil)
(repeat (sslength les)
(setq obj (ssname les i))
(setq info (entget obj))
(setq ac0 (cdr (assoc 0 info)))
(cond
((= ac0 "CIRCLE")
(progn
(setq dr40 (cdr (assoc 40 info)))
(setq pt10 (cdr (assoc 10 info)))
(setq clt (cons pt10 clt))
(setq pltlr (cons (polar pt10 0 dr40)
(cons (polar pt10 pi dr40) pltlr)
)
)
(setq pltud (cons (polar pt10 pi2 dr40)
(cons (polar pt10 3pi2 dr40) pltud)
)
)
)
)
((= ac0 "ARC")
(setq pt10 (cdr (assoc 10 info)))
(setq clt (cons pt10 clt))
)
((= ac0 "LINE")
(setq pt10 (cdr (assoc 10 info)))
(setq pt11 (cdr (assoc 11 info)))
(setq plt (cons pt10 (cons pt11 plt)))
)
)
)
(prin1)
)

(defun c:pp ( ) 
  (princ "\n简单投影程序，制作BY菜卷鱼") 
  (setq pi2 (/ pi 2)) 
  (setq 3pi2 (/ (* 3 pi) 2)) 
  (setq  les (ssget '((0 . "LINE,CIRCLE,ARC") 
         (-4 . "<NOT") 
         (8 . "中心线") 
         (-4 . "NOT>") 
        ) 
      ) 
  ) 
  (setq i 0) 
  (setq pltlr nil) 
  (setq pltud nil) 
  (setq clt nil) 
  (setq plt nil) 
  (repeat (sslength les) 
    (setq obj (ssname les i)) 
    (setq info (entget obj)) 
    (setq ac0 (cdr (assoc 0 info))) 
    (cond 
      ((= ac0 "CIRCLE") 
       (progn 
   (setq dr40 (cdr (assoc 40 info))) 
   (setq pt10 (cdr (assoc 10 info))) 
   (setq clt (cons pt10 clt)) 
   (setq pltlr (cons (polar pt10 0 dr40) 
         (cons (polar pt10 pi dr40) pltlr) 
         ) 
   ) 
   (setq pltud (cons (polar pt10 pi2 dr40) 
         (cons (polar pt10 3pi2 dr40) pltud) 
         ) 
   ) 
       ) 
      ) 
      ((= ac0 "ARC") 
       (setq pt10 (cdr (assoc 10 info))) 
       (setq clt (cons pt10 clt)) 
      ) 
      ((= ac0 "LINE") 
       (setq pt10 (cdr (assoc 10 info))) 
       (setq pt11 (cdr (assoc 11 info))) 
       (setq plt (cons pt10 (cons pt11 plt))) 
      ) 
    ) 
  ) 
(prin1) 
)

以下是完整源码

(defun c:pps (/ mm_lay pi2 2pi 3pi2 les i pltlr pltud clt plt
obj info ac0 dr40 pt10 starc edarc pt11 pt10s p10
n alist alist1 alist2 lft rht upt dnt cor1 cor2 cor3
cor4 pcenter locat key xcor1 xcor2 xcor3 xcor4 plistn
loc1 loc2 locat2 locn1 locn2 lcline0 clocat clocat2
lcline1 lcline2 celine0 celine1 celine2 pt1 pt2
oldline pt1 pt2 pt3 pt0 *error* erases mvs vxs)
(defun erases (ss / i) ;;;;等于(command "erase")
(setq i -1)
(repeat (sslength ss)
(entdel (ssname ss (setq i (1+ i))))
))
(defun mvs (lst / a lst2) ;;;列表去重
(while (setq a (car lst) lst2 (cons a lst2) lst (vl-remove a lst)))
(reverse lst2)
)
(defun vxs (e / i v lst) ;;;;获得多义线端点
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
(defun *error*(s)
(setvar 'cmdecho 0)
(command "_.ucs" "p")
(command "_.undo" "e")
(setvar 'cmdecho 1)
(redraw)
)
(princ "\n简单投影程序,制作BY菜卷鱼")
(setvar "cmdecho" 0)
(command "_.undo" "be")
(command "_.ucs" "")
(if (null (tblsearch "layer" "03中心线"))
(progn (setq mm_lay (getvar "CLAYER"))
(setvar "cmdecho" 0)
(command "_layer" "m" "03中心线" "c"
"1" "" "l" "center" ""
"lw" "0.18" "03中心线" "")
(setvar "cmdecho" 1)
(setvar "clayer" mm_lay)))
(if (null (tblsearch "layer" "04虚线"))
(progn (setq mm_lay (getvar "CLAYER"))
(setvar "cmdecho" 0)
(command "_layer" "m" "04虚线" "c" "2"
"" "l" "DASHED" "" "lw"
"0.18" "04虚线" "")
(setvar "cmdecho" 1)
(setvar "clayer" mm_lay)))
(setq pi2 (/ pi 2))
(setq 2pi (* pi 2))
(setq 3pi2 (/ (* 3 pi) 2))
(setq les (ssget '((0 . "LINE,CIRCLE,ARC,LWPOLYLINE")
(-4 . "<NOT")
(8 . "*03中心线*")
(-4 . "NOT>")
)
)
)
(setq i 0)
(repeat (sslength les)
(setq obj (ssname les i))
(setq info (entget obj))
(setq ac0 (cdr (assoc 0 info)))
(cond
((= ac0 "CIRCLE")
(progn
(setq dr40 (cdr (assoc 40 info)))
(setq pt10 (cdr (assoc 10 info)))
(setq clt (cons pt10 clt))
(setq pltlr (cons (polar pt10 0 dr40)
(cons (polar pt10 pi dr40) pltlr)
)
)
(setq pltud (cons (polar pt10 pi2 dr40)
(cons (polar pt10 3pi2 dr40) pltud)
)
)
)
)
;;;;;;;;;;;;;;;
((= ac0 "ARC")
(setq dr40 (cdr (assoc 40 info)))
(setq pt10 (cdr (assoc 10 info)))
;; (setq clt (cons pt10 clt))
(setq starc (cdr (assoc 50 info)))
(setq edarc (cdr (assoc 51 info)))
;;;;
(if
(or
(and (= starc 0) (= edarc pi))
(and (= starc pi) (= edarc 0))
(and (= starc pi2) (= edarc 3pi2))
(and (= starc 3pi2) (= edarc pi2))
)
(setq clt (cons pt10 clt))
)
(cond
((or
(and (<= starc pi2) (<= pi2 edarc) (< edarc 3pi2))
(and (<= pi2 edarc) (< edarc 3pi2 starc))
)
(setq pltud (cons (polar pt10 pi2 dr40) pltud))
)
;;上
((or
(and (<= starc pi2) (>= edarc 3pi2))
(and (<= starc pi2) (< edarc pi2))
(and (> starc 3pi2) (>= edarc 3pi2))
)
(setq pltud (cons (polar pt10 pi2 dr40)
(cons (polar pt10 3pi2 dr40) pltud)
)
)
)
;;LT上下
((<= pi2 edarc starc 3pi2)
(setq pltud (cons (polar pt10 pi2 dr40)
(cons (polar pt10 3pi2 dr40) pltud)
)
)
)
;;RG上下
((and
(> starc pi2)
(<= starc 3pi2)
(or (>= edarc 3pi2) (and (>= edarc 0) (< edarc pi2))))
(setq pltud (cons (polar pt10 3pi2 dr40) pltud))
)
)
;;下
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond
((and (<= starc pi edarc) (> starc 0))
(setq pltlr (cons (polar pt10 pi dr40) pltlr))
)
;;;左
((<= pi edarc starc)
(setq pltlr (cons (polar pt10 0 dr40)
(cons (polar pt10 pi dr40) pltlr)
)
)
)
;;;UP左右
((>= pi starc edarc)
(setq pltlr (cons (polar pt10 0 dr40)
(cons (polar pt10 pi dr40) pltlr)
)
)
)
;;;DN左右
((< edarc pi starc)
(setq pltlr (cons (polar pt10 0 dr40) pltlr))
)
;;;右
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((= ac0 "LINE")
(setq pt10 (cdr (assoc 10 info)))
(setq pt11 (cdr (assoc 11 info)))
(setq plt (cons pt10 (cons pt11 plt)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
((= ac0 "LWPOLYLINE")
(setq pt10s (vxs obj))
(setq plt (append pt10s plt))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
)
(setq i (1+ i))
)
(setq alist (append plt pltlr pltud))
(setq
alist1
(vl-sort alist
(function (lambda (e1 e2) (< (car e1) (car e2))))
)
)
(setq lft (car alist1))
(setq rht (car (reverse alist1)))
(setq alist2
(vl-sort alist
(function (lambda (e1 e2) (> (cadr e1) (cadr e2))))
)
)
(setq upt (car alist2))
(setq dnt (car (reverse alist2)))
(setq alist1 (mvs alist1))
(setq alist2 (mvs alist2))
(setq cor1 (mapcar '+
(mapcar '* lft '(1 0 1))
(mapcar '* upt '(0 1 1))
)
)
(setq cor2 (mapcar '+
(mapcar '* lft '(1 0 1))
(mapcar '* dnt '(0 1 1))
)
)
(setq cor3 (mapcar '+
(mapcar '* rht '(1 0 1))
(mapcar '* upt '(0 1 1))
)
)
(setq cor4 (mapcar '+
(mapcar '* rht '(1 0 1))
(mapcar '* dnt '(0 1 1))
)
)
(setq pcenter (inters cor1 cor4 cor3 cor2 nil))
(setq locat (getpoint pcenter "\n投影位置:"))
(if (> (abs (- (car locat) (car pcenter)))
(abs (- (cadr locat) (cadr pcenter)))
)
(setq key 0)
;;;x方向投影
(setq key 1)
;;;y方向投影
)
(cond
((= key 0)
(setq
xcor1 (mapcar '+ cor1 '(99999 0 0))
xcor2 (mapcar '+ cor2 '(99999 0 0))
xcor3 (mapcar '+ cor3 '(-99999 0 0))
xcor4 (mapcar '+ cor4 '(-99999 0 0))
)
(grdraw xcor1 xcor3 1 1)
(grdraw xcor2 xcor4 1 1)
)
((= key 1)
(setq
xcor1 (mapcar '+ cor1 '(0 99999 0))
xcor2 (mapcar '+ cor2 '(0 -99999 0))
xcor3 (mapcar '+ cor3 '(0 99999 0))
xcor4 (mapcar '+ cor4 '(0 -99999 0))
)
(grdraw xcor1 xcor2 1 1)
(grdraw xcor3 xcor4 1 1)
)
)
(cond
((= key 0)
(setq plistn (append plt pltud))
(setq loc1 (mapcar '+
(mapcar '* locat '(1 0 1))
(mapcar '* upt '(0 1 1))
)
)
(setq loc2 (mapcar '+
(mapcar '* locat '(1 0 1))
(mapcar '* dnt '(0 1 1))
)
)
)
((= key 1)
(setq plistn (append plt pltlr))
(setq loc1 (mapcar '+
(mapcar '* locat '(0 1 1))
(mapcar '* lft '(1 0 1))
)
)
(setq loc2 (mapcar '+
(mapcar '* locat '(0 1 1))
(mapcar '* rht '(1 0 1))
)
)
)
)
(grdraw loc1 loc1 1 1)
(setq locat2 (getpoint locat "\n投影宽度:"))
(cond
((= key 0)
(setq locn1 (mapcar '+
(mapcar '* locat2 '(1 0 1))
(mapcar '* upt '(0 1 1))
)
)
(setq locn2 (mapcar '+
(mapcar '* locat2 '(1 0 1))
(mapcar '* dnt '(0 1 1))
)
)
(setq
lcline0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) plistn))
(if (> (car locat) (car locat2))
(setq clocat locat
clocat2 locat2
)
(setq clocat locat2
clocat2 locat
)
)
(setq lcline1
(mapcar
'(lambda (x) (mapcar '+ x (mapcar '* locat '(1 0 1))))
lcline0
)
)
(setq lcline2
(mapcar
'(lambda (x) (mapcar '+ x (mapcar '* locat2 '(1 0 1))))
lcline0
)
)
(setq celine0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) clt))
(setq celine1
(mapcar
'(lambda (x)
(mapcar '+ x '(10 0 0) (mapcar '* clocat '(1 0 1)))
)
celine0
)
)
(setq
celine2 (mapcar '(lambda (x)
(mapcar '+
x
'(-10 0 0)
(mapcar '* clocat2 '(1 0 1))
)
)
celine0
)
)
)
((= key 1)
(setq locn1 (mapcar '+
(mapcar '* locat2 '(0 1 1))
(mapcar '* lft '(1 0 1))
)
)
(setq locn2 (mapcar '+
(mapcar '* locat2 '(0 1 1))
(mapcar '* rht '(1 0 1))
)
)
(setq
lcline0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) plistn))
(if (> (cadr locat) (cadr locat2))
(setq clocat locat
clocat2 locat2
)
(setq clocat locat2
clocat2 locat
)
)
(setq lcline1
(mapcar
'(lambda (x) (mapcar '+ x (mapcar '* locat '(0 1 1))))
lcline0
)
)
(setq lcline2
(mapcar
'(lambda (x) (mapcar '+ x (mapcar '* locat2 '(0 1 1))))
lcline0
)
)
(setq celine0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) clt))
(setq celine1
(mapcar
'(lambda (x)
(mapcar '+ x '(0 10 0) (mapcar '* clocat '(0 1 1)))
)
celine0
)
)
(setq
celine2 (mapcar '(lambda (x)
(mapcar '+
x
'(0 -10 0)
(mapcar '* clocat2 '(0 1 1))
)
)
celine0
)
)
)
)
(grdraw locn1 locn1 1 1)
(entmake (list '(0 . "line")
'(8 . "0")
(cons 10 loc1)
(cons 11 loc2)
)
)
(entmake (list '(0 . "line")
'(8 . "0")
(cons 10 locn1)
(cons 11 locn2)
)
)
(repeat
(length plistn)
(setq pt1 (car lcline1))
(setq lcline1 (cdr lcline1))
(setq pt2 (car lcline2))
(setq lcline2 (cdr lcline2))
(setq oldline (ssget "_w" pt1 pt2))
(if (and (/= oldline nil) (/= (sslength oldline) 0))
(erases oldline)
)
(entmake (list '(0 . "line")
'(8 . "04虚线")
(cons 10 pt1)
(cons 11 pt2)
)
)
)
(repeat (length clt)
(setq pt1 (car celine1))
(setq celine1 (cdr celine1))
(setq pt2 (car celine2))
(setq celine2 (cdr celine2))
(setq oldline (ssget "_w" pt1 pt2))
(if (and (/= oldline nil) (/= (sslength oldline) 0))
(erases oldline)
)
(entmake (list '(0 . "line")
'(8 . "03中心线")
(cons 10 pt1)
(cons 11 pt2)
)
)
)
(setq oldline (ssget "_w" loc1 locn1))
(if (and (/= oldline nil) (/= (sslength oldline) 0))
(erases oldline)
)
(entmake (list '(0 . "line")
'(8 . "0")
(cons 10 loc1)
(cons 11 locn1)
)
)
(setq oldline (ssget "_w" loc2 locn2))
(if (and (/= oldline nil) (/= (sslength oldline) 0))
(erases oldline)
)
(entmake (list '(0 . "line")
'(8 . "0")
(cons 10 loc2)
(cons 11 locn2)
)
)
(command "_.ucs" "p")
(command "_.undo" "e")
(setvar "cmdecho" 0)
(prin1)
)
(princ "\n简单投影程序,制作BY菜卷鱼")
(prin1)
(prin1)

(defun c:pps  (/ mm_lay pi2 2pi 3pi2 les i pltlr pltud clt plt 
obj info ac0 dr40 pt10 starc edarc pt11 pt10s p10 
n alist alist1 alist2 lft rht upt dnt cor1 cor2 cor3 
cor4 pcenter locat key xcor1 xcor2 xcor3 xcor4 plistn 
loc1 loc2 locat2 locn1 locn2 lcline0 clocat clocat2 
lcline1 lcline2 celine0 celine1 celine2 pt1 pt2 
oldline pt1 pt2 pt3 pt0 *error* erases mvs vxs) 
(defun erases (ss / i)    ;;;;等于(command "erase") 
(setq i -1) 
(repeat (sslength ss) 
(entdel (ssname ss (setq i (1+ i)))) 
)) 
(defun mvs (lst / a lst2)  ;;;列表去重 
  (while (setq a (car lst) lst2 (cons a lst2) lst (vl-remove a lst))) 
  (reverse lst2) 
) 
(defun vxs (e / i v lst)   ;;;;获得多义线端点 
  (setq i -1) 
  (while 
    (setq v (vlax-curve-getpointatparam e (setq i (1+ i)))) 
     (setq lst (cons v lst)) 
  ) 
  (reverse lst) 
) 
(defun *error*(s)   
(setvar 'cmdecho 0) 
(command "_.ucs" "p") 
(command "_.undo" "e") 
(setvar 'cmdecho 1) 
(redraw) 
) 
  (princ "\n简单投影程序,制作BY菜卷鱼") 
  (setvar "cmdecho" 0) 
  (command "_.undo" "be") 
  (command "_.ucs" "") 
  (if (null (tblsearch "layer" "03中心线")) 
    (progn (setq mm_lay (getvar "CLAYER")) 
           (setvar "cmdecho" 0) 
           (command "_layer" "m"      "03中心线"        "c" 
                    "1"             ""              "l"      "center"        "" 
                    "lw"     "0.18"   "03中心线"        "") 
           (setvar "cmdecho" 1) 
           (setvar "clayer" mm_lay))) 
 
  (if (null (tblsearch "layer" "04虚线")) 
    (progn (setq mm_lay (getvar "CLAYER")) 
           (setvar "cmdecho" 0) 
           (command "_layer" "m"      "04虚线" "c"        "2" 
                    ""             "l"      "DASHED" ""        "lw" 
                    "0.18"   "04虚线" "") 
           (setvar "cmdecho" 1) 
           (setvar "clayer" mm_lay))) 
  (setq pi2 (/ pi 2)) 
  (setq 2pi (* pi 2)) 
  (setq 3pi2 (/ (* 3 pi) 2)) 
  (setq        les (ssget '((0 . "LINE,CIRCLE,ARC,LWPOLYLINE") 
                     (-4 . "<NOT") 
                     (8 . "*03中心线*") 
                     (-4 . "NOT>") 
                     ) 
                   ) 
        ) 
  (setq i 0) 
  (repeat (sslength les) 
    (setq obj (ssname les i)) 
    (setq info (entget obj)) 
    (setq ac0 (cdr (assoc 0 info))) 
    (cond 
      ((= ac0 "CIRCLE") 
       (progn 
         (setq dr40 (cdr (assoc 40 info))) 
         (setq pt10 (cdr (assoc 10 info))) 
         (setq clt (cons pt10 clt)) 
         (setq pltlr (cons (polar pt10 0 dr40) 
                           (cons (polar pt10 pi dr40) pltlr) 
                           ) 
               ) 
         (setq pltud (cons (polar pt10 pi2 dr40) 
                           (cons (polar pt10 3pi2 dr40) pltud) 
                           ) 
               ) 
         ) 
       ) 
;;;;;;;;;;;;;;; 
      ((= ac0 "ARC") 
       (setq dr40 (cdr (assoc 40 info))) 
       (setq pt10 (cdr (assoc 10 info))) 
       ;; (setq clt (cons pt10 clt)) 
       (setq starc (cdr (assoc 50 info))) 
       (setq edarc (cdr (assoc 51 info))) 
;;;; 
       (if 
         (or 
           (and (= starc 0) (= edarc pi)) 
           (and (= starc pi) (= edarc 0)) 
           (and (= starc pi2) (= edarc 3pi2)) 
           (and (= starc 3pi2) (= edarc pi2)) 
           ) 
          (setq clt (cons pt10 clt)) 
          ) 
       (cond 
         ((or 
 
            (and (<= starc pi2) (<= pi2 edarc) (< edarc 3pi2)) 
            (and (<= pi2 edarc) (< edarc 3pi2 starc)) 
            ) 
          (setq pltud (cons (polar pt10 pi2 dr40) pltud)) 
          ) 
         ;;上 
         ((or 
            (and (<= starc pi2) (>= edarc 3pi2)) 
            (and (<= starc pi2) (< edarc pi2)) 
            (and (> starc 3pi2) (>= edarc 3pi2)) 
            ) 
          (setq        pltud (cons (polar pt10 pi2 dr40) 
                            (cons (polar pt10 3pi2 dr40) pltud) 
                            ) 
                ) 
          ) 
         ;;LT上下 
         ((<= pi2 edarc starc 3pi2) 
          (setq        pltud (cons (polar pt10 pi2 dr40) 
                            (cons (polar pt10 3pi2 dr40) pltud) 
                            ) 
                ) 
          ) 
         ;;RG上下 
         ((and 
            (> starc pi2) 
            (<= starc 3pi2) 
            (or (>= edarc 3pi2) (and (>= edarc 0) (< edarc pi2)))) 
          (setq pltud (cons (polar pt10 3pi2 dr40) pltud)) 
          ) 
         ) 
       ;;下 
;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
       (cond 
         ((and (<= starc pi edarc) (> starc 0)) 
          (setq pltlr (cons (polar pt10 pi dr40) pltlr)) 
          ) 
;;;左 
         ((<= pi edarc starc) 
          (setq        pltlr (cons (polar pt10 0 dr40) 
                            (cons (polar pt10 pi dr40) pltlr) 
                            ) 
                ) 
          ) 
;;;UP左右 
         ((>= pi starc edarc) 
          (setq        pltlr (cons (polar pt10 0 dr40) 
                            (cons (polar pt10 pi dr40) pltlr) 
                            ) 
                ) 
          ) 
;;;DN左右 
         ((< edarc pi starc) 
          (setq pltlr (cons (polar pt10 0 dr40) pltlr)) 
          ) 
;;;右 
         ) 
       ) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
      ((= ac0 "LINE") 
       (setq pt10 (cdr (assoc 10 info))) 
       (setq pt11 (cdr (assoc 11 info))) 
       (setq plt (cons pt10 (cons pt11 plt))) 
       ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
      ((= ac0 "LWPOLYLINE") 
(setq pt10s (vxs obj)) 
        (setq plt (append pt10s plt)) 
       ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
      ) 
    (setq i (1+ i)) 
    ) 
  (setq alist (append plt pltlr pltud)) 
  (setq 
    alist1 
     (vl-sort alist 
              (function (lambda (e1 e2) (< (car e1) (car e2)))) 
              ) 
    ) 
  (setq lft (car alist1)) 
  (setq rht (car (reverse alist1))) 
  (setq        alist2 
         (vl-sort alist 
                  (function (lambda (e1 e2) (> (cadr e1) (cadr e2)))) 
                  ) 
        ) 
  (setq upt (car alist2)) 
  (setq dnt (car (reverse alist2))) 
(setq alist1 (mvs alist1)) 
(setq alist2 (mvs alist2)) 
  (setq        cor1 (mapcar '+ 
                     (mapcar '* lft '(1 0 1)) 
                     (mapcar '* upt '(0 1 1)) 
                     ) 
        ) 
  (setq        cor2 (mapcar '+ 
                     (mapcar '* lft '(1 0 1)) 
                     (mapcar '* dnt '(0 1 1)) 
                     ) 
        ) 
  (setq        cor3 (mapcar '+ 
                     (mapcar '* rht '(1 0 1)) 
                     (mapcar '* upt '(0 1 1)) 
                     ) 
        ) 
  (setq        cor4 (mapcar '+ 
                     (mapcar '* rht '(1 0 1)) 
                     (mapcar '* dnt '(0 1 1)) 
                     ) 
        ) 
 
  (setq pcenter (inters cor1 cor4 cor3 cor2 nil)) 
 
  (setq locat (getpoint pcenter "\n投影位置:")) 
 
  (if (> (abs (- (car locat) (car pcenter))) 
         (abs (- (cadr locat) (cadr pcenter))) 
         ) 
    (setq key 0) 
;;;x方向投影 
    (setq key 1) 
;;;y方向投影 
    ) 
 
  (cond 
    ((= key 0) 
     (setq 
       xcor1 (mapcar '+ cor1 '(99999 0 0)) 
       xcor2 (mapcar '+ cor2 '(99999 0 0)) 
       xcor3 (mapcar '+ cor3 '(-99999 0 0)) 
       xcor4 (mapcar '+ cor4 '(-99999 0 0)) 
       ) 
     (grdraw xcor1 xcor3 1 1) 
     (grdraw xcor2 xcor4 1 1) 
     ) 
    ((= key 1) 
     (setq 
       xcor1 (mapcar '+ cor1 '(0 99999 0)) 
       xcor2 (mapcar '+ cor2 '(0 -99999 0)) 
       xcor3 (mapcar '+ cor3 '(0 99999 0)) 
       xcor4 (mapcar '+ cor4 '(0 -99999 0)) 
       ) 
     (grdraw xcor1 xcor2 1 1) 
     (grdraw xcor3 xcor4 1 1) 
     ) 
    ) 
 
  (cond 
    ((= key 0) 
     (setq plistn (append plt pltud)) 
     (setq loc1        (mapcar        '+ 
                        (mapcar '* locat '(1 0 1)) 
                        (mapcar '* upt '(0 1 1)) 
                        ) 
           ) 
     (setq loc2        (mapcar        '+ 
                        (mapcar '* locat '(1 0 1)) 
                        (mapcar '* dnt '(0 1 1)) 
                        ) 
           ) 
     ) 
    ((= key 1) 
     (setq plistn (append plt pltlr)) 
     (setq loc1        (mapcar        '+ 
                        (mapcar '* locat '(0 1 1)) 
                        (mapcar '* lft '(1 0 1)) 
                        ) 
           ) 
     (setq loc2        (mapcar        '+ 
                        (mapcar '* locat '(0 1 1)) 
                        (mapcar '* rht '(1 0 1)) 
                        ) 
           ) 
     ) 
    ) 
  (grdraw loc1 loc1 1 1) 
 
  (setq locat2 (getpoint locat "\n投影宽度:")) 
  (cond 
    ((= key 0) 
     (setq locn1 (mapcar '+ 
                         (mapcar '* locat2 '(1 0 1)) 
                         (mapcar '* upt '(0 1 1)) 
                         ) 
           ) 
     (setq locn2 (mapcar '+ 
                         (mapcar '* locat2 '(1 0 1)) 
                         (mapcar '* dnt '(0 1 1)) 
                         ) 
           ) 
     (setq 
       lcline0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) plistn)) 
     (if (> (car locat) (car locat2)) 
       (setq clocat  locat 
             clocat2 locat2 
             ) 
       (setq clocat  locat2 
             clocat2 locat 
             ) 
       ) 
     (setq lcline1 
            (mapcar 
              '(lambda (x) (mapcar '+ x (mapcar '* locat '(1 0 1)))) 
              lcline0 
              ) 
           ) 
     (setq lcline2 
            (mapcar 
              '(lambda (x) (mapcar '+ x (mapcar '* locat2 '(1 0 1)))) 
              lcline0 
              ) 
           ) 
     (setq celine0 (mapcar '(lambda (x) (mapcar '* x '(0 1 1))) clt)) 
     (setq celine1 
            (mapcar 
              '(lambda (x) 
                 (mapcar '+ x '(10 0 0) (mapcar '* clocat '(1 0 1))) 
                 ) 
              celine0 
              ) 
           ) 
     (setq 
       celine2 (mapcar '(lambda        (x) 
                          (mapcar '+ 
                                  x 
                                  '(-10 0 0) 
                                  (mapcar '* clocat2 '(1 0 1)) 
                                  ) 
                          ) 
                       celine0 
                       ) 
       ) 
     ) 
    ((= key 1) 
     (setq locn1 (mapcar '+ 
                         (mapcar '* locat2 '(0 1 1)) 
                         (mapcar '* lft '(1 0 1)) 
                         ) 
           ) 
     (setq locn2 (mapcar '+ 
                         (mapcar '* locat2 '(0 1 1)) 
                         (mapcar '* rht '(1 0 1)) 
                         ) 
           ) 
     (setq 
       lcline0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) plistn)) 
     (if (> (cadr locat) (cadr locat2)) 
       (setq clocat  locat 
             clocat2 locat2 
             ) 
       (setq clocat  locat2 
             clocat2 locat 
             ) 
       ) 
     (setq lcline1 
            (mapcar 
              '(lambda (x) (mapcar '+ x (mapcar '* locat '(0 1 1)))) 
              lcline0 
              ) 
           ) 
     (setq lcline2 
            (mapcar 
              '(lambda (x) (mapcar '+ x (mapcar '* locat2 '(0 1 1)))) 
              lcline0 
              ) 
           ) 
     (setq celine0 (mapcar '(lambda (x) (mapcar '* x '(1 0 1))) clt)) 
     (setq celine1 
            (mapcar 
              '(lambda (x) 
                 (mapcar '+ x '(0 10 0) (mapcar '* clocat '(0 1 1))) 
                 ) 
              celine0 
              ) 
           ) 
     (setq 
       celine2 (mapcar '(lambda        (x) 
                          (mapcar '+ 
                                  x 
                                  '(0 -10 0) 
                                  (mapcar '* clocat2 '(0 1 1)) 
                                  ) 
                          ) 
                       celine0 
                       ) 
       ) 
     ) 
    ) 
  (grdraw locn1 locn1 1 1) 
 
 
  (entmake (list '(0 . "line") 
                 '(8 . "0") 
                 (cons 10 loc1) 
                 (cons 11 loc2) 
                 ) 
           ) 
  (entmake (list '(0 . "line") 
                 '(8 . "0") 
                 (cons 10 locn1) 
                 (cons 11 locn2) 
                 ) 
           ) 
 
  (repeat 
    (length plistn) 
     (setq pt1 (car lcline1)) 
     (setq lcline1 (cdr lcline1)) 
     (setq pt2 (car lcline2)) 
     (setq lcline2 (cdr lcline2)) 
     (setq oldline (ssget "_w" pt1 pt2)) 
 
     (if (and (/= oldline nil) (/= (sslength oldline) 0)) 
(erases oldline) 
       ) 
 
     (entmake (list '(0 . "line") 
                    '(8 . "04虚线") 
                    (cons 10 pt1) 
                    (cons 11 pt2) 
                    ) 
              ) 
     ) 
 
  (repeat (length clt) 
    (setq pt1 (car celine1)) 
    (setq celine1 (cdr celine1)) 
    (setq pt2 (car celine2)) 
    (setq celine2 (cdr celine2)) 
    (setq oldline (ssget "_w" pt1 pt2)) 
 
    (if        (and (/= oldline nil) (/= (sslength oldline) 0)) 
(erases oldline) 
      ) 
 
    (entmake (list '(0 . "line") 
                   '(8 . "03中心线") 
                   (cons 10 pt1) 
                   (cons 11 pt2) 
                   ) 
             ) 
    ) 
 (setq oldline (ssget "_w" loc1 locn1)) 
 
  (if (and (/= oldline nil) (/= (sslength oldline) 0)) 
(erases oldline) 
    ) 
 
  (entmake (list '(0 . "line") 
                 '(8 . "0") 
                 (cons 10 loc1) 
                 (cons 11 locn1) 
                 ) 
           ) 
  (setq oldline (ssget "_w" loc2 locn2)) 
 
  (if (and (/= oldline nil) (/= (sslength oldline) 0)) 
(erases oldline) 
    ) 
 
  (entmake (list '(0 . "line") 
                 '(8 . "0") 
                 (cons 10 loc2) 
                 (cons 11 locn2) 
                 ) 
           ) 
  (command "_.ucs" "p") 
  (command "_.undo" "e") 
  (setvar "cmdecho" 0) 
  (prin1) 
  ) 
  (princ "\n简单投影程序,制作BY菜卷鱼") 
(prin1) 
 
(prin1)

xj6019 · 发表于 2020-2-25 12:17:54

本帖最后由 xj6019 于 2020-2-25 13:54 编辑

您好老师，程序试用了一下，不知道您贴出来的代码和现成的文件里面有没有区别，我两个都试了发现了点小问题，看看能解决么
我的附件里面这种形状用程序投影，相邻的两个线挨着太紧的话，就只能投影出一根线来，请问能解决吗
小点的图都没问题，一旦如图板很薄但是整个断面很宽的时候，投影就总出这个问题，你的两部分代码我都试过了，效果均相同. 会不定时一会好一会不行，都没有规律，相同的断面，运行代码时好时坏，代码的判断还不是固定的吗？搞不懂咋回事呢，好奇怪！
求解决方案，谢谢！！

xzklk · 发表于 2020-9-18 13:04:45

这要谁能写一个补全三视图就厉害了，经常碰到那样的三视图给了两视，要自己画第三个试图的。烦人得很！要是有3D我不自己用UG之类的出工程图就是

ming1789_55399 · 发表于 2019-10-31 11:34:34

感謝分享

陨落 · 发表于 2014-1-10 10:03:11

cad也可以画3d图啊

hao3ren · 发表于 2014-1-10 10:40:23

cad三维太弱了

tcsl9621 · 发表于 2014-1-10 11:29:14

看看这个原理是什么。

江湖远人 · 发表于 2014-1-10 11:36:08

支持一下！

819534890 · 发表于 2014-1-10 11:36:26

先看完整的

风雨依然 · 发表于 2014-1-10 11:49:28

下载收藏了

sachindkini · 发表于 2014-1-10 12:35:34

dear sir,
nice program

flyfox1047 · 发表于 2014-1-10 12:43:14

CAD画三维也不错的，只是没有数据结构，三维投影三视可参考 zctao1966的转三视图程序

zctao1966 · 发表于 2014-1-10 12:46:20

CAD也可以画三维，画好之后也可以转三视图的

账号		自动登录	找回密码
密码			注册

[源码] 简单的投影程序

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源

点评