lisp2arx
Visual Programming for AutoLisp
Mathématiques en programmation Lisp..
doc2cpp,doc2lsp, sld2lsp, bmp2dcl,
free__GifCcapture for all-CAD'platforms..
|
Lista Forumurilor Pe Tematici
|
lisp2arx | Reguli | Inregistrare | Login
POZE LISP2ARX
Nu sunteti logat.
|
Nou pe simpatie:
Roxxxi23 la Simpatie.ro
 | Femeie
23 ani
Neamt
cauta Barbat
23 - 52 ani |
|
|
admin
Administrator
Din: Bucharest
Inregistrat: acum 13 ani
Postari: 508
|
|
Code:
(princ)(setq kHereAiciHeirIciAqui 0767004316 erprv nil)(Defun asserte(a251 / rr qw)(setq acad__assertNo(+ acad__assertNo 1))(if(=(type a251)(quote INT))(setq a251(abs a251)a251(strcat"a"(if(< a251 100)"0""")(itoa a251))))(if(/=(type a251)(quote STR))(setq a251"a251err<>str"))(if(= acad__assertNo kHereAiciHeirIciAqui)(alert(strcat"You acad::eUserBreak\n"(itoa kHereAiciHeirIciAqui))))(setq erprv erlsp erlsp(strcat"\n"a251"<"(itoa acad__assertNo)">"))erlsp)(prompt"\nCommand.com=STB[enter]\n")(DeFun C:STB()(setq acad__assertNo 0)(dfn_cad_asysset)#endregio(setq layer.dll(getvar"CLAYER"))(setq tplay(getString T(strcat"\nGiveMe LayerName forBrlock<"layer.dll">:")))(if(= tplay nil)(setq tplay layer.dll))(setq idok(if(tblsearch"LAYER"tplay)tplay"0"))(setq _ax(pp_citruset idok))(command)(princ"\nEnd")rr)(defun dfn_cad_asysset(/ rr io kj su bya lpt)(setq su"")(setq lpt(list(list"MODEMACRO"(strcat su" "))(list"ORTHOMODE"0)(list"ISAVEBAK"1)(list"SAVETIME"15)(list"BLIPMODE"0)))(syst_setvars lpt)(setq io(vl-load-com))rr)(defun pp_citruset(slayerxp / $rr ndx ssst $db $i nm enb ene en3 nop jsr dyn)(setq $i(- 0 1)ssst(ssget))(if(= ssst nil)(progn(alert(strcat"\n*error* eSubSelectionSetEmpty_i550\n""Like_citrus-----------\n"":-Title(~LISP similar to commandBlock~)\n"":-Warning : Entmakex contain Bugs or Crash"))))(setq ene nil ndx 0)(progn(setq $db T)(while $db(setq $i(+ $i 1)nm(strcat"Block-"(itoa $i)))(setq $db(tblobjname"block"nm))))(setq st(getpoint"\nInsertion point: ")st(if(= st nil)(getvar"VIEWCTR")st)enb(entmake(list(cons 0"BLOCK")(cons 100"AcDbEntity")(cons 67 0)(cons 8 sLayerxp)(cons 100"AcDbBlockReference")(cons 2 nm)(cons 10 st)(cons 70 0))))(princ)(if enb(repeat(sslength ssst)(list(entmake(cdr(entget(ssname ssst ndx))))(princ)(setq ndx(+ 1 ndx)))))(if(> ndx 0)(setq ene(entmake(list(cons 0"ENDBLK")(cons 100"AcDbBlockEnd")(cons 8"0")))))(setq $rr(if ene(entmake(list(cons 0"INSERT")(cons 2 nm)(cons 6(getvar"CELTYPE"))(cons 8 sLayerxp)(cons 66 0)(cons 10 st)(cons 41 1)(cons 42 1)(cons 43 1)(cons 50 0)(cons 71 0)(cons 44 0)(cons 45 0)))nil))(princ)(setq dyn(dfn_getx_readkey"[DYN]""\nErase old entities(y.yes)(n.no)(d.yes-da): "))(if(and(> dyn"")(wcmatch dyn"*[YD]*"))(setq jsr(command"_.ERASE"ssst""))(setq $rr ssst))$rr)(setq syst_setvarname"")(Defun syst_setvars(listavar / $rr lpi $db om cfr)(setq $rr nil)(foreach lpi listavar(if(>(car lpi)"")(setq $db(car lpi)om(getvar $db)$rr(if om(append $rr(list(list $db om))$rr)(setq cfr(cadr lpi)om(if(= cfr nil)nil om)om(if(= cfr T)nil om)syst_setVarName $db om(if om(setvar $db cfr)nil))))))$rr)(defun dfn_getx_readkey(k574 t469 / retc kbd msg two chk lei)(setq retc(chr 0)kbd(if(> k574"")k574""))(setq msg(if(> t469"")t469"\nt469errorStr:"))(prompt msg)(progn(setq chk(if(>(strlen kbd)1)0 1))(while(= chk 0)(progn(setq two 0)(while(/= two 2)(setq lei(grread)two(car lei))(setq retc(strcase(chr(cadr lei))))(setq chk(if(> kbd"")(if(wcmatch retc kbd)1 0)0))))))(princ retc)retc)(prompt"\ncommand.com= stb[enter]\n") |
wanted to achieve the following in LISP, relating to creating a block:
- Select elements.
- Choose a point (usually Endpoint for one of the lines).
- Once the point is selected, two things happen. (1) Elements are deleted (2) A block is inserted with anchor or base at previous chosen point. This is done all on one step, triggered by the chosen point.
The above is similar to the BLOCK command which converts elements into a block. But I prefer not to enter a name, just to use randomly generated name.
Code:
(setq acad_iso11w100-extmin 4932 acad_iso11w100-extmax 59089)
(setq acad_isoQsortTime 00:00.00)
(setq runiftry11w100 (list (cons "0x0000" "c:/VLAXCOMPIL/0User/autofcol.lsp")
(cons "0x2A7A" "entmake");;County.xml=4
(cons "0x4E37" "getvar");;County.xml=2
(cons "0xE6D1" "dfn_getx_readkey");;County.xml=2
(cons "0x46CA" "wcmatch");;County.xml=2
(cons "0x6E00" "alert");;County.xml=2
(cons "0xABFF" "tblobjname");;County.xml=1
(cons "0x2ABB" "append");;County.xml=1
(cons "0x7EBC" "atoi");;County.xml=1
(cons "0x8223" "syst_setvars");;County.xml=1
(cons "0x63D7" "subst");;County.xml=1
(cons "0xD0B1" "ssget");;County.xml=1
(cons "0x4C2D" "sslength");;County.xml=1
(cons "0x7F6B" "vla-put-color");;County.xml=1
(cons "0x1344" "dfn_cad_asysset");;County.xml=1
(cons "0x624B" "strcase");;County.xml=1
(cons "0x9E77" "grread");;County.xml=1
(cons "0xDC92" "entget");;County.xml=1
(cons "0xA3DF" "getpoint");;County.xml=1
(cons "0x9F8D" "vl-load-com");;County.xml=1
(cons "0x48F2" "ssname");;County.xml=1
))
(setq getmypid nil js_getstatic12 nil setmypid "%s")
(if (car (atoms-family 1 '("vl-load-com"))) (progn (vl-load-com) (prompt "\n\n")))
(defun js_ldc11(mypid loopwne / rom subf)
(setq rom nil js_getstatic12 nil setmypid (substr mypid 1 4) subf (cdr (assoc mypid runiftry11w100)))
(if (vl-catch-all-error-p (setq rom (vl-catch-all-apply (read subf) loopwne)))
(setq js_getstatic12 (list "\n**T349errorH=" (vl-catch-all-error-message rom) "--setmypid=" setmypid subf "[" loopwne "]\n"))
(setq getmypid (cons setmypid getmypid))
) ;_ end of if
(if (/= js_getstatic12 nil) (princ js_getstatic12))
rom)
(setq acad_isoQsortTimp 00:00.00)
(setq acad_isoSortTotal 00:00.00)
(princ)
;;;inf=You run "c:\VLAXCOMPIL\0User\onlinesetup.cmd" before compile&link with external compilator.
;;;nam=autofcol.lsp
;;;{$R dfn_cad_amain}
;;;Inp: a251=int,
;;;rem: a251=tchar.
(setq kHereAiciHeirIciAqui 0767004316 erprv nil)
(Defun asserte(a251 / rr qw)
(setq;|a2846|;
acad__assertNo (+ acad__assertNo 1)) (if (= (type a251) (quote INT)) (setq;|a2898|;
a251 (abs a251)
a251 (strcat "a" (if (< a251 100) "0" "") (itoa a251)))) (if (/= (type a251) (quote STR)) (setq;|a3004|;
a251 "a251err<>str")) (if (= acad__assertNo kHereAiciHeirIciAqui) (js_ldc11 "0x6E00" (list (strcat "You acad::eUserBreak\n" (itoa kHereAiciHeirIciAqui))))) (setq;|a3070|;
erprv erlsp
erlsp (strcat "\n" a251 "<" (itoa acad__assertNo) ">"))
erlsp)
;;;Inf: Here is starting routine
(prompt "\nCommand.com=STB[enter]\n")
(DeFun C:STB()
(setq;|a3367|;
acad__assertNo 0) (js_ldc11 "0x1344" (list ))
#endregio
;;;{$R (call_stas)}
;------------------------Stdcall pp_citruscolor
(setq _ax (pp_citruscolor "0"))
;------------------------
;;;{$R -cad_amain_callend}
;;;rem:----------------------------------------------------------------------
(command) (princ "\nEnd")
rr)
;;;rem:---User Labels----cad_aPages-----
;;;rem:---pp_citruscolor----cad_aPages-----
;;;{$R dfn_cad_asysset}
(defun dfn_cad_asysset( / rr io kj su bya lpt)
(setq su "")
(setq;|a5329|;
lpt (list (list "MODEMACRO" (strcat su " ")) (list "ORTHOMODE" 0) (list "ISAVEBAK" 1) (list "SAVETIME" 15) (list "BLIPMODE" 0))) (js_ldc11 "0x8223" (list lpt)) (setq;|a5493|;
io (js_ldc11 "0x9F8D" (list )))
rr)
;;;{$E}
;;;{$R pp_citruscolor}
(Defun pp_citruscolor(sLayerxp / $rr ndx ssst $db $i nm enb ene en3 nop jsr dyn rgb ldc joc)
(setq;|a11783|;
$i (- 0 1)
ssst (js_ldc11 "0xD0B1" (list ))) (if (= ssst nil) (progn (js_ldc11 "0x6E00" (list (strcat "\n*error* eSubSelectionSetEmpty_i550\n" "Like_citrus SetColor-----------\n" ":-Title(~LISP similar to commandBlock~)\n" ":-Warning : Entmakex contain Bugs or Crash"))))) (setq;|a11901|;
ldc (js_ldc11 "0x4E37" (list "VIEWCTR"))
ene nil
ndx 0) (progn (setq;|a11959|;
$db T) (while $db (setq;|a11983|;
$i (+ $i 1)
nm (strcat "kBlockColor_i" (itoa $i))) (setq;|a12039|;
$db (js_ldc11 "0xABFF" (list "Block" nm))))) (setq;|a12079|;
st (js_ldc11 "0xA3DF" (list ldc "\nInsertion point(nil.viewcenter): "))
st (if (= st nil) ldc st)
enb (js_ldc11 "0x2A7A" (list (list (cons 0 "BLOCK") (cons 100 "AcDbEntity") (cons 67 0) (cons 8 sLayerxp) (cons 100 "AcDbBlockReference") (cons 2 nm) (cons 10 st) (cons 70 0))))) (princ) (setq;|a12375|;
rgb (if enb (js_ldc11 "0xE6D1" (list "[RGB1235]" "\nSetColor new(0.no-skip)(1.red)(3.green)(5.blue)(R.red)(G.green)(B.Blue)(2.yellow): ")) 0)) (setq;|a12419|;
rgb (if (= rgb "R") 1 (if (= rgb "G") 3 (if (= rgb "B") 5 (js_ldc11 "0x7EBC" (list rgb)))))) (if enb (repeat (js_ldc11 "0x4C2D" (list ssst)) (list (setq;|a12561|;
joc (js_ldc11 "0x48F2" (list ssst ndx))
nop (if (> rgb 0) (js_ldc11 "0x7F6B" (list (vlax-ename->vla-object joc) 72)) nop)
ele (cdr (js_ldc11 "0xDC92" (list joc)))
ele (if (> rgb 0) (js_ldc11 "0x63D7" (list (cons 62 rgb) (assoc 62 ele) ele)) ele)) (js_ldc11 "0x2A7A" (list ele)) (princ) (setq;|a12801|;
ndx (+ 1 ndx)))))
(setq readme.txt "(Subst (cons 62...)) return failed, IF-ele notContain(62.color)")
(if (> ndx 0) (setq;|a16069|;
ene (js_ldc11 "0x2A7A" (list (list (cons 0 "ENDBLK") (cons 100 "AcDbBlockEnd") (cons 8 "0")))))) (setq;|a16165|;
$rr (if ene (js_ldc11 "0x2A7A" (list (list (cons 0 "INSERT") (cons 2 nm) (cons 6 (getvar "CELTYPE")) (cons 8 sLayerxp) (cons 66 0) (cons 10 st) (cons 41 1) (cons 42 1) (cons 43 1) (cons 50 0) (cons 71 0) (cons 44 0) (cons 45 0)))) nil)) (princ) (setq;|a16533|;
dyn (js_ldc11 "0xE6D1" (list "[DYN]" "\nErase old entities(y.yes)(n.no)(d.yes-da): "))) (if (and (> dyn "") (js_ldc11 "0x46CA" (list dyn "*[YD]*"))) (setq;|a16605|;
jsr (command "_.ERASE" ssst "")) (setq;|a16645|;
$rr ssst))
$rr)
;;;{$R syst_setvars}
(setq syst_setvarname "")
(Defun syst_setvars(listavar / $rr lpi $db om cfr) ;_ASSERT_OK
(setq;|a19113|;
$rr nil) (foreach lpi listavar (if (> (car lpi) "") (setq;|a19185|;
$db (car lpi)
om (js_ldc11 "0x4E37" (list $db))
$rr (if om (js_ldc11 "0x2ABB" (list $rr (list (list $db om)) $rr) (setq;|a19321|;
cfr (cadr lpi)
om (if (= cfr nil) nil om)
om (if (= cfr T) nil om)
syst_setVarName $db
om (if om (setvar $db cfr) nil)))))))
$rr)
;;;{$R dfn_getx_readkey}
;;;inf:wait until press keys k
(defun dfn_getx_readkey(k574 t469 / retc kbd msg two chk lei)
(setq;|a22122|;
retc (chr 0)
kbd (if (> k574 "") k574 "")) (setq;|a22182|;
msg (if (> t469 "") t469 "\nt469errorStr:")) (prompt msg) (progn (setq;|a22232|;
chk (if (> (strlen kbd) 1) 0 1)) (while (= chk 0) (progn (setq;|a22288|;
two 0) (while (/= two 2) (setq;|a22326|;
lei (js_ldc11 "0x9E77" (list ))
two (car lei)) (setq;|a22374|;
retc (js_ldc11 "0x624B" (list (chr (cadr lei))))) (setq;|a22414|;
chk (if (> kbd "") (if (js_ldc11 "0x46CA" (list retc kbd)) 1 0) 0)))))) (princ retc)
retc)
;;;{$E}
;lib:free
(prompt "\ncommand.com= stb[enter]\n")
|
39.2KB
_______________________________________
|
|
| pus acum 3 ani |
|
