 - ;;;(wHILE (PRINC (STRCAT "\n" (VL-PRINC-TO-STRING (GRREAD T)))))
- (defun C:CLOUD ()
- (grtext -1 "\n 画云妆线程序开始...<钱勇编>")
- (SETVAR "PLINEWID" 0)
- (SETVAR "OSMODE" 0)
- (SETQ A (GETPOINT "\n 请输入云状线的起始点:.."))
- (setq p (grread T))
- (princ)
- (setq pT (cadr p))
- (command "line" A PT "")
- (SETQ LS (ENTLAST))
- (setq line1 (entget LS))
- (COMMAND "PLINE" A)
- (setq p (grread T))
- (setq k (car p))
- (SETQ PT (cADR P))
- (setq p1 (TRANS PT 1 0))
- (setq line1 (subst (CONS 11 P1) (assoc 11 line1) line1))
- (entmod line1)
- (setq mm T)
- (while mm
- (setq line1 (subst (CONS 11 P1) (assoc 11 line1) line1))
- (entmod line1)
- (setq p (grread T))
- (setq k (car p))
- (setq pT (cadr p))
- (IF (or (= (type PT) 'INT) (= (type PT) 'REAL))
- (SETQ P1 (lIST 0 0 0))
- (SETQ P1 (TRANS PT 1 0))
- )
- (if (= k 3)
- (cOMMAND PT)
- )
- (IF (= K 25)
- (PROGN
- (SETQ MM NIL)
- (COMMAND A "")
- (ENTDEL LS)
- )
- )
- )
- ;;;_____________________________________
- (setq ent (entlast))
- (REDRAW ENT 3)
- (setq ED1 (entget eNT))
- (setq newed ent)
- (ENTDEL NEWED)
- (setq #len (length ED1))
- (SETQ COUNT 0)
- (WHILE (< COUNT #LEN)
- (setq #it (NTH (- #LEN COUNT 1) ED1))
- (SETQ COUNT (1+ COUNT))
- (SETQ LTM (CAR #iT))
- (IF (/= 42 LTM)
- (SETQ BIAO (CONS #IT BIAO))
- (PROGN
- (SETQ #IT (CONS 42 0.5))
- (SETQ BIAO (CONS #IT BIAO))
- ) ;PROGN
- ) ;IF
- ) ;while
- (ENTMAKE BIAO)
- (setq bizo nil)
- (prompt ".云妆线")
- (PRINC)
- )
|