大量LISP原码免费下载

ghf

http://www.jtbworld.com/lisp.htm

ghf

http://www.jtbworld.com/lisp.htm

ghf

http://paracadd.com/lisp.htm

ghf

lace a standard Profile Grid array
;beginning at the point you specify and terminating at
;the north and east distances you specify.
;Uses UPOINT.LSP
;
;        AUTHOR: HENRY C. FRANCIS
;                425 N. ASHE ST.
;                SOUTHERN PINES, NC 28387
;                All rights reserved without prejudice.
;
;        Copyright:        5-28-96
;        Edited:                5-28-96
;
(defun c:adgrid ( / )
  (setq llcor (upoint 1 "" "Lower left corner of new grid area" (if llcor llcor nil) nil))
  (setq urcor (upoint 1 "" "Upper right corner of new grid area" (if urcor urcor nil) nil))
  (setq llx (car llcor)
        lly (cadr llcor)
        llz (caddr llcor)
        urx (car urcor)
        ury (cadr urcor)
        hgy lly
        vgx llx
        count 0
  );setq
  (setq mjrg "C"
        llt "-"
        prod "SHBD"
        colra "D"
        modf "GRID"
  );setq
  (c:mklayr)
  (while
    (<= hgy ury)
    (if(eq(rem count 10)0)
      (progn
        (setq colra "E")
        (c:mklayr)
      );progn
    );if
    (entmake
      (list
        (cons 0 "LINE")
        (cons 10 (list llx hgy llz))
        (cons 11 (list urx hgy llz))
      )
    )
    (if(eq colra "E")
      (progn
        (setq colra "D")
        (c:mklayr)
      );progn
    );if
    (setq hgy (+ hgy 10))
    (setq count (1+ count))
  );while
  (setq count 0)
  (while
    (<= vgx urx)
    (if(eq(rem count 4)0)
      (progn
        (setq colra "E")
        (c:mklayr)
      );progn
    );if
    (entmake
      (list
        (cons 0 "LINE")
        (cons 10 (list vgx lly llz))
        (cons 11 (list vgx ury llz))
      )
    )
    (if(eq colra "E")
      (progn
        (setq colra "D")
        (c:mklayr)
      );progn
    );if
    (setq vgx (+ vgx 25))
    (setq count (1+ count))
  );while
);defun

ghf

;;;Modify the text width factor of a selection set of text entities.
;;;       The only input required is the desired
;;;       text width factor and selection of the text to modify.  There
;;;       is no need to worry about not selecting non-text entities
;;;       because they will be automatically filtered out of the
;;;       selection set.
;;;
;;;        AUTHOR: HENRY C. FRANCIS
;;;                425 N. ASHE ST.
;;;                SOUTHERN PINES, NC 28387
;;;              
;;;                All rights reserved without prejudice.
;;;        Copyright:        6-7-94
;;;        Edited:                6-18-99
;;;
(DEFUN C:TWID (/ tset tsln cntr tent edtw)
  (SETQ        twf (ureal 1
                   ""
                   "\nText Width Factor "
                   (IF twf
                     twf
                     1.0
                   ) ;_ end of if
            ) ;_ end of ureal
  )                                        ;
  (PROMPT "\nSelect Text: ")
  (SETQ        tset (SSGET '((-4 . "<or")
                      (0 . "TEXT")
                      (0 . "ATTDEF")
                      (-4 . "<and")
                      (0 . "INSERT")
                      (66 . 1)
                      (-4 . "and>")
                      (-4 . "or>")
                     )
             ) ;_ end of ssget
  ) ;_ end of setq
  (IF tset
    (PROGN
      (SETQ tsln (SSLENGTH tset))
      (SETQ cntr 0)
    ) ;_ end of progn
  ) ;_ end of if
  (WHILE
    (IF        (AND (< cntr tsln) tset)
      (SETQ tent (ENTGET (SSNAME tset cntr)))
    )                                        ;if
     (PROGN
       (SETQ edtw (ENTGET (CDAR tent)))
       (IF (OR
             (EQ (CDR (ASSOC 0 edtw)) "TEXT")
             (EQ (CDR (ASSOC 0 edtw)) "ATTDEF")
           )                                ;or
         (PROGN
           (SETQ edtw
                  (SUBST (CONS 41 twf)
                         (ASSOC 41 edtw)
                         edtw
                  ) ;_ end of subst
           ) ;_ end of setq
           (ENTMOD edtw)
         ) ;_ end of progn
         (WHILE        (/= (CDR (ASSOC 0 edtw)) "SEQEND")
           (COND ((EQ (CDR (ASSOC 0 edtw)) "ATTRIB")
                  (GRDRAW (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 1.25)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 0.25)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          -1
                          1
                  ) ;_ end of GRDRAW
                  (GRDRAW (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 1.75)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 0.75)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          -1
                          1
                  ) ;_ end of GRDRAW
                  (SETQ        mod_attrq (ukword 1
                                          "Yes No"
                                          (STRCAT "\nModify attribute, Tag = <"
                                                  (CDR (ASSOC 2 edtw))
                                                  ">, Value = <"
                                                  (CDR (ASSOC 1 edtw))
                                                  ">?"
                                          ) ;_ end of strcat
                                          (IF mod_attrq
                                            mod_attrq
                                            "No"
                                          ) ;_ end of if
                                  ) ;_ end of ukword
                  ) ;_ end of setq
                  (GRDRAW (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 1.25)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 0.25)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          -1
                          1
                  ) ;_ end of GRDRAW
                  (GRDRAW (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 1.75)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          (POLAR (CDR (ASSOC 10 edtw))
                                 (* PI 0.75)
                                 (CDR (ASSOC 40 edtw))
                          ) ;_ end of polar
                          -1
                          1
                  ) ;_ end of GRDRAW
                  (IF (EQ mod_attrq "Yes")
                    (PROGN
                      (SETQ edtw
                             (SUBST (CONS 41 twf)
                                    (ASSOC 41 edtw)
                                    edtw
                             ) ;_ end of subst
                      ) ;_ end of setq
                      (ENTMOD edtw)
                      (ENTUPD (CDAR tent))
                    ) ;_ end of progn
                  ) ;_ end of if
                 )
           ) ;_ end of COND
           (SETQ edtw (ENTGET (ENTNEXT (CDR (ASSOC -1 edtw)))))
         ) ;_ end of WHILE
       ) ;_ end of if
     ) ;_ end of progn
     (SETQ cntr (1+ cntr))
  ) ;_ end of while
)                                        ;DEFUN

;|玍isual LISP?Format Options?(84 2 40 2 T "end of " 60 9 2 0 0 T T nil T)
***Don't add text below the comment!***|;

ghf

;Semi-auto placement of D.I.P. Hatch pattern in profile. (on MHP sewers)
;
;        AUTHOR: HENRY C. FRANCIS
;                425 N. ASHE ST.
;                SOUTHERN PINES, NC 28387
;              
;                All rights reserved without prejudice.
;        Copyright:        1-30-96
;        Edited:                1-30-96
;
(defun c:diph (/ solss ss count sslen dimsc curel dipx2 whend howm)
  (setq solss (ssget '((0 . "SOLID")))
        ss (ssadd)
        count 0
        sslen (sslength solss)
        dimsc (getvar"dimscale")
        curel (getvar"elevation")
        colr "3"
        llt "-"
        prod "SSWR"
        modf "PATT"
  );setq
  (setvar"elevation"(* 1002 dimsc))
  (setvar"hpang"0)
  (setvar"hpname""ansi31")
  (setvar"hpscale"(/ dimsc 2))
  (c:svlayr)
  (c:mklayr)
  (if (eq sslen 1)
    (progn
      (setq sent (entget(ssname solss count))
            plp1 (cdr(assoc 10 sent))
            plp1 (list(car plp1)(cadr plp1)(* dimsc 1002))
            plp2 (cdr(assoc 11 sent))
            plp2 (list(car plp2)(cadr plp2)(* dimsc 1002))
            plp3 (cdr(assoc 12 sent))
            plp3 (list(car plp3)(cadr plp3)(* dimsc 1002))
            plp4 (cdr(assoc 13 sent))
            plp4 (list(car plp4)(cadr plp4)(* dimsc 1002))
      );setq
      (setq howm (ukword 1 "All Part" "All or Part DIP?" "All"))
      (cond
        ((eq howm "Part")
          (setq dipx (upoint 1 "" "Station of End Between Manholes" nil nil)
                dipx (list(car dipx)(cadr dipx)(* dimsc 1002))
                colr "2"
                modf "NEWW"
          );setq
          (c:mklayr)
          (setq whend (ukword 1 "Right Left Distance" "Right, Left or Distance" "Distance"))
        )
      );cond
      (cond
        ((and(eq howm "Part")(eq whend "Distance"))
          (setq distx (ureal 1 "" "Distance (+ right, - left)" (if distx distx nil)))
          (setq dipx2 (list(+(car dipx)distx)(cadr dipx)(caddr dipx))
                plp1 (inters plp1 plp2 dipx (polar dipx (/ pi 2) 1) nil)
                plp2 (inters plp1 plp2 dipx2 (polar dipx2 (/ pi 2) 1) nil)
                plp3 (inters plp4 plp3 dipx (polar dipx (/ pi 2) 1) nil)
                plp4 (inters plp3 plp4 dipx2 (polar dipx2 (/ pi 2) 1) nil)
          );setq
          (command ".line" plp1 plp3 "")
          (command ".line" plp2 plp4 "")
        )
        ((and(eq howm "Part")(eq whend "Right"))
          (setq plp1 (inters plp1 plp2 dipx (polar dipx (/ pi 2) 1) nil)
                plp3 (inters plp3 plp4 dipx (polar dipx (/ pi 2) 1) nil)
          );setq
          (command ".line" plp1 plp3 "")
        )
        ((and(eq howm "Part")(eq whend "Left"))
          (setq plp2 (inters plp1 plp2 dipx (polar dipx (/ pi 2) 1) nil)
                plp4 (inters plp3 plp4 dipx (polar dipx (/ pi 2) 1) nil)
          );setq
          (command ".line" plp2 plp4 "")
        )
      );cond
      (setq colr "3"
            modf "PATT"
      );setq
      (c:mklayr)
      (command ".pline" plp1 plp2 plp4 plp3 "c")
      (setq ss (ssadd (entlast) ss))
    );progn
    (while (not(eq count sslen))
      (setq sent (entget(ssname solss count))
            plp1 (cdr(assoc 10 sent))
            plp1 (list(car plp1)(cadr plp1)(* dimsc 1002))
            plp2 (cdr(assoc 11 sent))
            plp2 (list(car plp2)(cadr plp2)(* dimsc 1002))
            plp3 (cdr(assoc 12 sent))
            plp3 (list(car plp3)(cadr plp3)(* dimsc 1002))
            plp4 (cdr(assoc 13 sent))
            plp4 (list(car plp4)(cadr plp4)(* dimsc 1002))
      );setq
      (command ".pline" plp1 plp2 plp4 plp3 "c")
      (setq ss (ssadd (entlast) ss)
            count (1+ count)
      );setq
    );while
  );if
  (command ".hatch" "" "" "" "l" "")
  (c:rslayr)
  (command ".erase" ss "")
  (setvar"elevation"curel)
  (princ)
);defun

ghf

lisp.rar (225.15 KB, 下载次数: 113)

2008-1-31 13:17 上传

点击文件名下载附件

ghf

shajianlin

收到，不错！谢谢
请问，怎样控制autolisp在输出到文本时，控制写到指定行？