Advertisement
Jgug

AutoLISP L2 LSP

Nov 25th, 2012
2,833
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (defun hello ()
  2.     (setq dcl_id (load_dialog "f:\\work\\dialog.dcl") dx_on "0.1" dy_on "0.1" out "0" n 8)
  3.     (while (< 2 n)
  4.         (if(not(new_dialog "hello" dcl_id)) (exit))
  5.         (set_tile "dx" dx_on)
  6.         (set_tile "dy" dy_on)
  7.         (set_tile "Out" out)
  8.         (action_tile "dx" "(setq dx_on $value)")
  9.         (action_tile "dy" "(setq dy_on $value)")
  10.         (action_tile "calc" "(fOne)")
  11.         (action_tile "accept" "(fTwo)(done_dialog 1)")
  12.         (setq n (start_dialog))
  13.     )
  14.     (unload_dialog dcl_id)
  15. )
  16.  
  17. (defun fOne ()
  18.     (setq nabor (ssget "X" '((0 . "LINE"))))
  19.     (setq size (sslength nabor))
  20.     (setq i 0 n1 0 n2 0)
  21.     (setq fdx (atof dx_on) fdy (atof dy_on))
  22.     (while (< i size)
  23.         (setq P (ssname nabor i))
  24.         (setq prim (entget P))
  25.         (setq startL (assoc 10 prim))
  26.         (setq endL (assoc 11 prim))
  27.         (setq start (cdr startL)) ;êîîðäèíòû íà÷àëà
  28.         (setq end (cdr endL)) ;êîîðäèíàòû êîíöà
  29.         (setq xs (car start)) ;X êîîðäèíàòà íà÷àëà
  30.         (setq ys (cadr start)) ;Y êîîðäèíàòà íà÷àëà
  31.         (setq xe (car end)) ;X êîîðäèíàòà êîíöà
  32.         (setq ye (cadr end)) ;Y êîîðäèíàòà êîíöà
  33.         (setq newxe xe)
  34.         (setq newye ye)
  35.         (setq vX (abs (- xs xe)))
  36.         (setq vY (abs (- ys ye)))
  37.         (cond
  38.             ((< vX fdx) (progn (setq newxe xs) (setq n1 (+ 1 n1)))) ;íîâîå çíà÷åíèå X êîíöà îòðåçêà, åñëè TRUE
  39.             ((< vY fdy) (progn (setq newye ys) (setq n2 (+ 1 n2)))) ;íîâîå çíà÷åíèå Y êîíöà îòðåçêà, åñëè TRUE
  40.         )
  41.         (setq i (+ 1 i))
  42.     )
  43.     (setq sum (+ n1 n2))
  44.     (set_tile "Out" (itoa sum))
  45. )
  46.  
  47. (defun fTwo ()
  48.     (setq nabor (ssget "X" '((0 . "LINE"))))
  49.     (setq size (sslength nabor))
  50.     (setq j 0)
  51.     (setq fdx (atof dx_on))
  52.     (setq fdy (atof dy_on))
  53.     (while (< j size)
  54.         (setq P (ssname nabor j))
  55.         (setq prim (entget P))
  56.         (setq startL (assoc 10 prim))
  57.         (setq endL (assoc 11 prim))
  58.         (setq start (cdr startL)) ;êîîðäèíòû íà÷àëà
  59.         (setq end (cdr endL)) ;êîîðäèíàòû êîíöà
  60.         (setq xs (car start)) ;X êîîðäèíàòà íà÷àëà
  61.         (setq ys (cadr start)) ;Y êîîðäèíàòà íà÷àëà
  62.         (setq xe (car end)) ;X êîîðäèíàòà êîíöà
  63.         (setq ye (cadr end)) ;Y êîîðäèíàòà êîíöà
  64.         (setq newxe xe)
  65.         (setq newye ye)
  66.         (setq vX (abs (- xs xe)))
  67.         (setq vY (abs (- ys ye)))
  68.         (cond
  69.             ((< vX fdx) (setq newxe xs)) ;íîâîå çíà÷åíèå X êîíöà îòðåçêà, åñëè TRUE
  70.             ((< vY fdy) (setq newye ys)) ;íîâîå çíà÷åíèå Y êîíöà îòðåçêà, åñëè TRUE
  71.         )
  72.         (setq new_end (list 11 newxe newye 0.0)) ;ñîçäàíèå íîâîãî ñïèñêà êîîðäèíàò êîíöà
  73.         (setq prim (subst new_end endL prim)) ;çàìåíà ñòàðîãî ñïèñêà ñ êîîðäèíàòàìè êîíöà ïðåîáðàçîâàííûì
  74.         (entmod prim) ;ïðèìåíåíèå èçìåíåíèé
  75.         (entupd P)
  76.         (setq j (+ 1 j))
  77.     )
  78. )  
  79.        
  80. (hello)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement