Centar za edukaciju-BiH

iCentar → Racunari i oprema → Softver i operativni sistemi → Autocad → Autolisp


Prosiri i skupi Opcije teme
Stranice (1):1

#1 21.09.2010 22:57
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Postovi:10,612


Predmet:Korisni lispovi
Trim do teksta.
PreuzmiIzvorni kôd (Lisp):
  1. ;TIP1222.LSP:     TB.LSP     Text Break     (c)1996, Yuqun Lian;;; This routine writes a text string to the drawing and then breaks any
  2. ;;; lines, polylines, etc. that intersect an imaginary box around the text.
  3. ;;; The text is placed on the current layer using the current style. The
  4. ;;; default input and repeat capabilities of TB.LSP make multiple labeling
  5. ;;; very convenient.;;; Yuqun Lian - SimpleCAD    
  6. ;;; ------------------------------------------------------------------------
  7. (defun tberror (S)
  8.   (if (/= S "Function cancelled")
  9.     (princ (strcat "\nError: " S))
  10.   )
  11.   (setvar "CLAYER" TEMPLA)
  12.   (setvar "BLIPMODE" TEMPBLIP)
  13.   (setvar "OSMODE" TEMPOS)
  14.   (setvar "CMDECHO" TEMPCMD)
  15.   (setq *error* OLDERR)
  16.   (princ)
  17. ) ;end tberror(defun C:TB ( / TEMP FIRST TX ANG TEMPLA TEMPCMD TEMPBLIP
  18.   TEMPOS TXTST TXTH)
  19.   (setq OLDERR *error*
  20.   *error* TBERROR)
  21.   (setq TEMPCMD (getvar "CMDECHO")
  22.     TEMPLA  (getvar "CLAYER")
  23.     TEMPBLIP (getvar "BLIPMODE")
  24.     TEMPOS (getvar "OSMODE")
  25.     TXTST (getvar "TEXTSTYLE")
  26.   *TXTH (getvar "TEXTSIZE"))
  27.   (setvar "CMDECHO" 0)
  28.   (setvar "BLIPMODE" 0)
  29.   (setq TXTH (cdr (assoc 40 (tblsearch "style" TXTST))))   (setq TEMP T)
  30.   (setq FIRST T)
  31.   (while TEMP
  32.     (setvar "OSMODE" 512)    
  33.     (setq PT1 (getpoint "\nInsertion point for text: "))    
  34.     (setvar "OSMODE" 0)
  35.     (cond
  36.       ((/= PT1 nil)
  37.         (if FIRST
  38.           (progn            (if (= TXTH 0)
  39.               (progn
  40.                 (princ "\nHeight <")
  41.                 (princ *TXTH)
  42.                 (setq H (getreal ">: "))
  43.                 (if (= H nil) (setq H *TXTH)(setq *TXTH H))
  44.               )
  45.             )            (if (not *ANG)(setq *ANG 0))
  46.             (princ "\nRotation angle <")
  47.             (princ (* *ANG (/ 180 3.1415926)))
  48.             (setq ANG (getangle PT1 ">: "))
  49.             (if (not ANG)(setq ANG *ANG)(setq *ANG ANG))
  50.             (setq ANG (* ANG (/ 180 3.1415926)))                (if (not *TEXT)(setq *TEXT "XXX"))
  51.             (princ "\nText <")
  52.             (princ *TEXT)
  53.             (setq TX (getstring T ">: "))
  54.             (if (= TX "") (setq TX *TEXT)(setq *TEXT TX))
  55.           ) ;end progn
  56.         ) ;end first        (if (= TXTH 0)
  57.           (command "text" "j" "mc" PT1 *TXTH ANG TX )
  58.         (command "text" "j" "mc" PT1  ANG TX ))
  59.         (trimbox)
  60.       ) ;end pt1      ((null PT1)
  61.       (setq TEMP nil))    );end cond
  62.     (setq FIRST nil)
  63.   );end while  (setvar "CLAYER" TEMPLA)
  64.   (setvar "BLIPMODE" TEMPBLIP)
  65.   (setvar "OSMODE" TEMPOS)
  66.   (setvar "CMDECHO" TEMPCMD)
  67.   (princ)
  68. )      (defun trimbox (/ TEXTENT TRIMFACT TB GAP FGAP LL UR
  69.   PTB1 PTB2 PTB3 PTB4 PTF1 PTF2 PTF3 PTF4 BX)
  70.   (setq TEXTENT (entlast))
  71.   (setq TRIMFACT 0.5) ;trim gap and text height ratio  
  72.   (command "ucs" "Entity" TEXTENT)
  73.   (setq TB (textbox (list (cons -1 TEXTENT)))
  74.     LL (car TB)
  75.     UR (cadr TB)
  76.   )
  77.   (setq GAP (* *TXTH TRIMFACT))    
  78.   (setq FGAP (* GAP 0.5))
  79.   (setq PTB1 (list (- (car LL) GAP) (- (cadr LL) GAP))
  80.     PTB3 (list (+ (car UR) GAP) (+ (cadr UR) GAP))
  81.     PTB2 (list (car PTB3) (cadr PTB1))
  82.     PTB4 (list (car PTB1) (cadr PTB3))
  83.     PTF1 (list (- (car LL) FGAP) (- (cadr LL) FGAP))
  84.     PTF3 (list (+ (car UR) FGAP) (+ (cadr UR) FGAP))
  85.     PTF2 (list (car PTF3) (cadr PTF1))
  86.     PTF4 (list (car PTF1) (cadr PTF3))
  87.   )
  88.   (command "pline" PTB1 PTB2 PTB3 PTB4 "c")
  89.   (setq BX (entlast))
  90.   (command "trim" BX "" "f" PTF1 PTF3 PTF4 PTF1 "" "")
  91.   (entdel BX)
  92.   (redraw TEXTENT)
  93.   (command "ucs" "p")
  94.   (princ)
  95. ) ;end trimbox(princ "\nWritten by Yuqun Lian")
  96. (princ "\nType TB to start")
  97. (princ); end tb.lsp
  98. 
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
Ovaj post je ureden 2 puta. Posljednja izmjena 19.10.2010 03:19 od strane zxz. ↑  ↓

#2 04.01.2011 14:06
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Postovi:10,612


Predmet:Masinska pozicija
Masinska pozicija
PreuzmiIzvorni kôd (Lisp):
  1. (command "Layer" "s" "0" "")
  2. (setq V (getreal "Mjerilo 1:X: "))
  3. (setq B (/ 0.5 V))
  4. (setq txt "a")
  5. (while (/= txt "")
  6.   (setq txt (getstring "Poz: "))
  7.   (if (/= txt "")
  8.     (progn
  9.       (setq pt1 (getpoint "Po
  10. etak linije: "))
  11.       (setq pt2 (getpoint pt1 "Kraj linije: "))
  12.       (setq l (* (strlen txt) (/ 4 V)))
  13.       (if (or (> (car pt1) (car pt2)))
  14.         (progn
  15.           (setq pt3 (list (- (car pt2) l) (cadr pt2)))
  16.           (setq
  17.             pt4 (list (- (car pt2) (/ l 2)) (+ (cadr pt2) (/ 1.5 V)))
  18.           )
  19.           (setq ang (angle pt1 pt2))
  20.           (setq pt5 (polar pt1 ang 0.5))
  21.         )
  22.         (progn
  23.           (setq pt3 (list (+ (car pt2) l) (cadr pt2)))
  24.           (setq
  25.             pt4 (list (+ (car pt2) (/ l 2)) (+ (cadr pt2) (/ 1.5 V)))
  26.           )
  27.           (setq ang (angle pt1 pt2))
  28.           (setq pt5 (polar pt1 ang 0.5))
  29.         )
  30.       )
  31.     )
  32.   )
  33.   (command "Style" "arial" "Arial" "0" "1" "0" "N" "N")
  34.   (command "PLINE" pt1 "W" B "" pt5 "w" 0 "" pt2 "w" B "" pt3 "")
  35.   (command "TEXT" "C" pt4 (/ 4 V) 0 txt)
  36.   (command "DONUT" 0 B pt1 "")
  37.   (setvar "PLINEWID" 0)
  38.   (command "Style" "STANDARD" "" "" "" "" "" "" "N")
  39. )                                       ;progn
  40. );if
  41. );while
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
↑  ↓

#3 04.01.2011 14:08
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Postovi:10,612


Predmet:Ziva ograda
Geodetski prikaz zive ograde
PreuzmiIzvorni kôd (Lisp):
  1. *Ziva
  2. Ograda
  3. (command "Layer" "s" "Ograde" "")
  4. (setq pt1 (getpoint "Po
  5. etak linije: "))
  6. (setq pt2 (getpoint pt1 "Kraj linije: "))
  7. (setq ang (angle pt1 pt2))
  8. (setq pt3 (polar pt1 ang +10))
  9. (setq ang1 (+ ang 1.570796))
  10. (setq pt4 (polar pt3 ang1 +0.5))
  11. (setq duz1 (distance pt1 pt3))
  12. (setq duz (- (distance pt1 pt2) 20))
  13. (setq OSM (getvar "osmode"))
  14.  
  15. (command "LINE" pt1 pt2 "")
  16. (command "osmode" "0")
  17. (command "autosnap" 1)
  18. (command "circle" pt4 0.5)
  19. (while (< duz1 duz)
  20.   (setq pt3 (polar pt3 ang +10))
  21.   (setq pt4 (polar pt3 ang1 -0.5))
  22.   (setq duz1 (distance pt1 pt3))
  23.   (command "circle" pt4 0.5)
  24.  
  25.  
  26.   (setq pt3 (polar pt3 ang +10))
  27.   (setq pt4 (polar pt3 ang1 +0.5))
  28.   (setq duz1 (distance pt1 pt3))
  29.   (command "circle" pt4 0.5)
  30. )                                       ;While
  31.  
  32. (command "osmode" OSM)
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
↑  ↓

#4 07.03.2011 14:56
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Postovi:10,612


Predmet:Vrata od regala
Ova lisp procedura iscrtava nacrt vrata od regala i proporcionalno od ivica saru koja skoro uvijek ima na vratima.
Ako radite sa drvetom obavezno isprobajte.
PreuzmiIzvorni kôd (Lisp):
  1. ;*Sara
  2. ;Crtanje sare na vratima
  3. (command "ucs" "w")
  4. (setq pt1 (getpoint "Po
  5. etak crtanja Klik: "))
  6. ;(setq pt2 (getpoint pt1 "Kraj linije: "))
  7. ;(setq pt3 (getpoint pt2 "Kraj linije: "))
  8. (setq Duz (getreal "Dužina vrata: "))
  9. (setq Sir (getreal "Å irina vrata: "))
  10. (setq Rast (getreal  "Razmak: "))
  11.  
  12. (setq pt2 (list (+(car pt1) Duz) (cadr pt1)))
  13. (setq pt3 (list (car pt2) (+(cadr pt2) Sir)))
  14. (setq pt4 (list (car pt1) (cadr pt3)))
  15. (setq pt5 (list(+(car pt1) Rast) (+(cadr pt1) Rast)))
  16. (setq pt6 (list(-(car pt2) Rast) (+(cadr pt2) Rast)))
  17. (setq pt7 (list(-(car pt3) Rast) (-(cadr pt3) Rast)))
  18. (setq pt8 (list(+(car pt4) Rast) (-(cadr pt4) Rast)))
  19.  
  20. (setq konst (/(distance pt6 pt7) 332.029))
  21. (setq razmak1 (* konst 45.0218))
  22.  
  23. (setq pt9 (list(+(car pt5) razmak1) (cadr pt5)))
  24. (setq pt10 (list (car pt9) (cadr pt8)))
  25. (setq razmak1 (/(distance pt6 pt7) 2))
  26. (setq pt11 (list (car pt5) (-(cadr pt8) razmak1)))
  27. (setq razmak1 (* konst 152.77))
  28. (setq razmak2 (* konst 5.75))
  29. (setq pt12 (list(-(car pt10) razmak1) (-(cadr pt10) razmak2)))
  30. (setq pt13 (list(-(car pt9) razmak1) (+(cadr pt9) razmak2)))
  31. (setq razmak1 (* konst 21.42))
  32. (setq razmak2 (* konst 83.94))
  33. (setq pt14 (list(-(car pt10) razmak1) (-(cadr pt10) razmak2)))
  34. (setq pt15 (list(-(car pt9) razmak1) (+(cadr pt9) razmak2)))
  35. (setq razmak1 (* konst 147.0182))
  36. (setq pt16 (list(+(car pt11) razmak1) (cadr pt11)))
  37. (setq razmak1 (* konst 152.77))
  38. (setq pt17 (polar pt12 (angle pt12 pt6) razmak1))
  39. (setq pt18 (polar pt13 (angle pt13 pt7) razmak1))
  40.  
  41. (setq OSM (getvar "osmode"))
  42. (command "osmode" "0")
  43. (command "Layer" "s" "0" "" )
  44. (command "PLINE" pt1  pt2 pt3 pt4 pt1  "")
  45. (command "Layer" "s" "Sara" "")
  46. (command "PLINE" pt9  pt6 pt7 pt10 "A" "S" pt17 pt14 pt11 pt15 pt18 pt9 "")
  47.  
  48. (command "osmode" OSM)
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
↑  ↓

Stranice (1):1

Srodne teme

Ko je online?

Aktivni clanovi:
nema clanova


Kontakt
Sva vremena su GMT +02:00. Trenutno vrijeme: 12: 01 pm.