Info | File |
Tác giả: phamthanhbinh
Bài viết gốc: 225152
Tên lệnh: ttd |
lisp pick tọa độ từ hệ tọa độ cad sang vn2000
Bạn "like" mà gượng ép quá vậy >"<, của bạn đây nè, còn vụ elisp nhỏ hơn text mình nghĩ do máy bạn sao chứ mình bình...
>>
Bạn "like" mà gượng ép quá vậy >"<, của bạn đây nè, còn vụ elisp nhỏ hơn text mình nghĩ do máy bạn sao chứ mình bình thường ah vừa vặn
đấy vừa vặn tuy ko rộng rãi nhưng cũng ko bị trùng
sữa lại theo hệ tọa độ Trắc địa :D, lsp này mình sữa là dùng lsp của bạn post đấy nhá ^^, hình chứng minh đã đổi hệ tọa độ :D
Còn đây là lsp
(defun C:TTD (/ tencoc check-nova lytrinh accept nova baoloi node table style DCL_CDN DCL_ID FILE_DCL HTXT TEMP_CDN TSN
B1 B2 BB1 BB2 BBL BBR BK BL BLI BR BRI BT1 BT2 BTL BTR BTT BTX BTY EB1 EB2 EBK
PT1 PTE PTITLE PTL PTX PTY TD0 X Y SSNODE STTBTD TB ANG COL DEL DIX DIY EGPL EPL GR H K LST-TS N NAME
EVK OV SSC VBL VBR VK VLI VRI VTL VTR WH)
(command "style" "VnArial NarrowH" ".VnArial NarrowH" "" "" "" "" "")
(command "layer" "m" "QKHS" "c" "6" "" "")
(command "undo" "be")
(setvar "cmdecho" 0)
(command "undo" "begin")
(vl-load-com)
;======================= Defun ==========================
(defun rotate-text ( en ang / p1 p2 a e1)
(setq p1 (acet-geom-textbox (setq e1 (entget en)) 0)
p1 (acet-geom-midpoint (car p1) (caddr p1))
e1 (subst (cons 11 p1) (assoc 11 e1) e1)
a (cdr (assoc 50 e1))
a (+ ang a)
e1 (subst (cons 50 a) (assoc 50 e1) e1)
e1 (subst (cons 72 1) (assoc 72 e1) e1)
e1 (subst (cons 73 2) (assoc 73 e1) e1)
);setq
(entmod e1)
(entupd EN))
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun angle-d2r (ANGD) (if ANGD (/ (* pi ANGD) 180) nil))
(defun angle-r2d (ANGR) (if ANGR (/ (* 180 ANGR) pi) nil))
(defun grnode (point radius color ang node fomp hightlight / ANGi PT0 PT1 PTg COL)
(if fomp
(setq ANGi 0)
(setq ANGi (* 0.5 (angle-d2r ang))))
(if (= color 0) (setq COL 10) (setq COL color))
(setq PT0 (polar point ANGi radius) PTg PT0)
(if node (grdraw point PT0 color hightlight))
(while (<= ANGi (* 2 Pi))
(setq ANGi (+ ANGi (angle-d2r ang))
PT1 (polar point ANGi radius))
(if (= color 0) (setq COL (1+ COL)))
(if node (grdraw point PT0 COL hightlight) (grdraw PT0 PT1 COL hightlight))
(setq PT0 PT1)
);while
(if (not node) (grdraw PT0 PTg COL hightlight))
);end grnode
(defun tencoc (EN) (if (check-nova EN) (cdr (nth 7 (car(cdr (assoc -3 (entget EN '("*"))))))) (prompt "Doi tuong chon khong co du lieu tuyen")))
(defun check-nova (EN) (if (= (car(car(cdr (assoc -3 (entget EN '("*")))))) "TDNW") T nil))
(defun lytrinh (EN) (if (check-nova EN) (rtos (cdr (nth 5 (car(cdr (assoc -3 (entget EN '("*"))))))) 2 2) (prompt "Doi tuong chon khong co du lieu tuyen")))
(defun accept ()
(setq TD-value (list (get_tile "node") (get_tile "table") (nth (fix (atof (get_tile "style"))) Lst-TS)
(get_tile "height") (get_tile "name") (get_tile "start") 0)) (done_dialog))
(defun nova ()
(setq TD-value (list (get_tile "node") (get_tile "table") (nth (fix (atof (get_tile "style"))) Lst-TS)
(get_tile "height") (get_tile "name") (get_tile "start") 1)) (done_dialog))
(defun node ()
(if (and (= (get_tile "table") "0") (= (get_tile "node") "0")) (set_tile "table" "1")))
(defun table ()
(if (and (= (get_tile "table") "0") (= (get_tile "node") "0")) (set_tile "node" "1")))
(defun style (/ htxt htxt0)
(setq htxt0 (get_tile "height"))
(if (/= (setq htxt (cdr (assoc 40 (tblsearch "style" (nth (fix (atof (get_tile "style"))) Lst-TS))))) 0)
(progn (set_tile "height" (rtos htxt 2 3)) (mode_tile "height" 1))
(progn (mode_tile "height" 0) (set_tile "height" htxt0))))
(defun baoloi (val key valkey)
(if (= "." (substr val 1 1)) (setq val (strcat "0" val)))
(if (not (or (= val "") (and (or (= (type (read val)) 'REAL) (= (type (read val)) 'INT)) (> (atof val) 0))))
(progn
(if (or (= key "height") (= key "start"))
(repeat 2
(set_tile "err" (strcat " "))
(ACET-SYS-SLEEP 70)
(set_tile "err" (strcat "Gia tri " valkey " phai la so thuc duong"))
(ACET-SYS-SLEEP 120))
(repeat 2
(set_tile "err" (strcat " "))
(ACET-SYS-SLEEP 70)
(set_tile "err" (strcat "Gia tri " valkey " phai la so nguyen duong"))
(ACET-SYS-SLEEP 120)))
(mode_tile key 2)
(mode_tile key 3)
);progn
(set_tile "err" (strcat "Statistical coordinates data record - \Toa do "))
);if
);end error
(if (not TD-value) (setq TD-value (list "1" "1" (getvar "textstyle") "2.00" "N" "1" 0)))
(setq DCL_CDn (list
"Coordinate : dialog { value = \"http://taybac.1talk.net - \<Thong ke Toa do>\"; key = \"err\";"
" : column { children_alignment = top;"
" : boxed_row { "
" : column {"
" : toggle { key = \"node\"; label = \"Chen diem\"; height = 1.4;}"
" : toggle { key = \"table\"; label = \"Chen bang\"; height = 2.5;}}"
" : column {"
" : popup_list { key = \"style\"; label = \"Text Style\"; edit_width = 10.1;}"
" : edit_box { key = \"height\"; label = \"Height Text\"; height = 1.1; edit_width = 11;}"
" : tile { label = \"-\"; alignment = centered;}} "
" : column {"
" : edit_box { key = \"name\"; label = \" Ten diem\"; height = 1.1; edit_width = 4;}"
" : edit_box { key = \"start\"; label = \" So bat dau\"; height = 1.1; edit_width = 4;}"
" : tile { label = \"-\"; alignment = centered;}} "
" } "
" : button { key = \"nova\"; label = \"Export Station coodinates from Road-Plan\";}"
" : row {"
" : button { key = \"cancel\"; label = \" Thoat \"; is_cancel = true;}"
" : button { key = \"accept\"; label = \" Bat dau \"; is_default = true;}}"
" }"
" }"
"helpTLuy : dialog { label = \"Help and Copyright\U+00A9 Information\";"
" : column {"
" : row { : list_box { key = \"helpList\"; edit_width = 95; width = 98; height = 25;}}"
" : row { : button { key = \"okayHelp\"; label = \"Okay\"; is_default = false; is_cancel = true;}}"
" }"
" }"
)
TEMP_CDn (vl-filename-mktemp "CDn.DCL")
FILE_DCL (open TEMP_CDn "W"))
(foreach LL DCL_CDn (write-line LL FILE_DCL))
(close FILE_DCL)
(setq DCL_ID (load_dialog TEMP_CDn))
(new_dialog "Coordinate" DCL_ID)
(set_tile "node" (nth 0 TD-value))
(set_tile "table" (nth 1 TD-value))
(set_tile "height" (nth 3 TD-value))
(if (/= (setq htxt (cdr (assoc 40 (tblsearch "style" (nth 2 TD-value))))) 0)
(progn (set_tile "height" (rtos htxt 2 2)) (mode_tile "height" 1)))
(set_tile "name" (nth 4 TD-value))
(set_tile "start" (nth 5 TD-value))
(start_list "style")
(setq Lst-TS (list (nth 2 TD-value) (cdr (assoc 2 (tblnext "Style" T)))))
(while (setq TSN (tblnext "Style"))
(if (and (/= (cdr (assoc 2 TSN)) (nth 2 TD-value)) (/= (cdr (assoc 2 TSN)) ""))
(setq Lst-TS (append Lst-TS (list (cdr (assoc 2 TSN))))))
);while
(mapcar 'add_list Lst-TS)
(end_list)
(action_tile "cancel" "(exit)")
(action_tile "accept" "(accept)")
(action_tile "nova" "(nova)")
(action_tile "node" "(node)")
(action_tile "table" "(table)")
(action_tile "style" "(style)")
(action_tile "height" "(baoloi (get_tile \"height\") \"height\" \"''Cao chu''\")")
(action_tile "start" "(baoloi (get_tile \"start\") \"start\" \"''STT''\")")
(start_dialog)
(unload_dialog DCL_ID)
(vl-file-delete TEMP_CDn)
(setq H (atof (nth 3 TD-value)))
(if (wcmatch (cdr (assoc 3 (tblsearch "style" (nth 2 TD-value)))) "*AVAN*,*ARIAL*,*BLACK*") (setq Wh (* 1.5 H)) (setq Wh 0))
(if (= (nth 6 TD-value) 0) (progn
(if (/= (nth 3 TD-value) "") (setq N (nth 3 TD-value)))
(command "UCS" "W")
(setvar "dimzin" 0)
(command "undo" "begin")
(if (= (nth 5 TD-value) "") (setq k 0) (setq k (- (atof (nth 5 TD-value)) 1)))
(if (= (nth 1 TD-value) "1") ; BEGIN TABLE
(progn (prompt "Chon diem dat bang toa do...")
(while
(if (= (car (setq GR (grread 't 15 0))) 5)
(progn
(if (or (not COL) (= 249 COL)) (setq COL 1) (setq COL (1+ COL)))
(redraw)
(setq BTR (cadr GR)
BTL (polar BTR 0 (* H -26))
BT1 (polar BTR 0 (* H -21))
BT2 (polar BTR 0 (* H -10.5))
BBR (polar BTR (* 0.5 pi) (* H -11))
BBL (polar BTL (* 0.5 pi) (* H -11))
BB1 (polar BT1 (* 0.5 pi) (* H -11))
BB2 (polar BT2 (* 0.5 pi) (* H -11))
BR (polar BTR (* 0.5 pi) (* H -2.4))
BL (polar BTL (* 0.5 pi) (* H -2.4))
OV (* H 0.3)
VTR (polar BTR (* 0.25 pi) OV)
VTL (polar BTL (* 0.75 pi) OV)
VBR (polar BR (* 1.75 pi) OV)
VBL (polar BL (* 1.25 pi) OV))
(grdraw BTL BTR COL 1)
(grdraw BTL BBL COL 1)
(grdraw BTR BBR COL 1)
(grdraw BT1 BB1 COL 1)
(grdraw BT2 BB2 COL 1)
(grdraw BR BL COL 1)
(repeat 3
(setq BR (polar BR (* 0.5 pi) (* H -2.0))
BL (polar BL (* 0.5 pi) (* H -2.0))
BB1 (polar BT1 (* 0.5 pi) (* H -2.4))
BB2 (polar BT2 (* 0.5 pi) (* H -2.4)))
(grdraw BR BL COL 1)) T)
(progn
(setq PTitle (list (- (car BTR) (* 13 H)) (+ (cadr BTR) (* 1.8 H)))
BTX (list (- (car BTR) (* 15.75 H)) (+ (cadr BTR) (* -1.2 H)))
BTY (list (- (car BTR) (* 5.25 H)) (+ (cadr BTR) (* -1.2 H)))
BTT (list (- (car BTR) (* 23.5 H)) (+ (cadr BTR) (* -1.2 H)))
BR (polar BTR (* 0.5 pi) (* H -2.4))
BL (polar BTL (* 0.5 pi) (* H -2.4)))
(setq VK (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 8) '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)
(cons 10 VBR) (cons 10 VTR) (cons 10 VTL) (cons 10 VBL))))
(setq BK (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)
(cons 10 BR) (cons 10 BTR) (cons 10 BTL) (cons 10 BL))))
(setq B1 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2)
(cons 10 BB1) (cons 10 BT1))))
(setq B2 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2)
(cons 10 BB2) (cons 10 BT2))))
(entmake (list '(0 . "TEXT") (cons 10 PTitle) (cons 11 PTitle) (cons 40 (* 1.2 H))
(cons 1 "%¶ng Täa ®é ®iÓm") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(entmake (list '(0 . "TEXT") (cons 10 BTT) (cons 11 BTT) (cons 40 (* 1 H))
(cons 1 "§iÓm") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(entmake (list '(0 . "TEXT") (cons 10 BTX) (cons 11 BTX) (cons 40 (* 1 H))
(cons 1 "X") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(entmake (list '(0 . "TEXT") (cons 10 BTY) (cons 11 BTY) (cons 40 (* 1 H))
(cons 1 "Y") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq BTX (polar BTX (* -0.5 pi) (* 2.2 H))
BTY (polar BTY (* -0.5 pi) (* 2.2 H))
BTT (polar BTT (* -0.5 pi) (* 2.2 H)))
(prompt " OK Man!"))))));if END TABLE
(while
(progn
(initget 128 "u")
(setq TD0 (getpoint (strcat "\n Pick diem thu "(rtos (setq k (1+ k)) 2 0) " : ")))
(if (= TD0 "u") (vl-cmdf "undo" "Back") TD0))
(if (/= TD0 "u") (progn
(vl-cmdf "undo" "mark")
(princ TD0)
(setq X (rtos (cadr TD0) 2 3) Y (rtos (car TD0) 2 3))
(if (= (nth 1 TD-value) "1")
(progn ;put into table
(setq STTBTD (strcat (nth 4 TD-value) (rtos k 2 0)))
(entmake (list '(0 . "TEXT") (cons 10 BTT) (cons 11 BTT) (cons 40 (* 1 H))
(cons 1 STTBTD) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(entmake (list '(0 . "TEXT") (cons 10 BTX) (cons 11 BTX) (cons 40 (* 1 H))
(cons 1 X) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(entmake (list '(0 . "TEXT") (cons 10 BTY) (cons 11 BTY) (cons 40 (* 1 H))
(cons 1 Y) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq BTX (polar BTX (* -0.5 pi) (* 2 H))
BTY (polar BTY (* -0.5 pi) (* 2 H))
BTT (polar BTT (* -0.5 pi) (* 2 H)))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) (cons 10 BR) (cons 10 BL)))
(setq EB1 (entget B1) EB1 (subst (cons 10 (setq BB1 (polar BB1 (* -0.5 pi) (* 2 H)))) (assoc 10 EB1) EB1))
(entmod EB1) (entupd B1)
(setq EB2 (entget B2) EB2 (subst (cons 10 (setq BB2 (polar BB2 (* -0.5 pi) (* 2 H)))) (assoc 10 EB2) EB2))
(entmod EB2) (entupd B2)
(setq EBK (entget BK)
BRi (polar BR (* -0.5 pi) (* 2 H))
BLi (polar BL (* -0.5 pi) (* 2 H))
EBK (reverse (subst (cons 10 BRi) (assoc 10 EBK) EBK))
EBK (reverse (subst (cons 10 BLi) (assoc 10 EBK) EBK))
BR Bri BL BLi)
(entmod EBK) (entupd BK)
(setq EVK (entget VK)
VRi (polar VBR (* -0.5 pi) (* 2 H))
VLi (polar VBL (* -0.5 pi) (* 2 H))
EVK (reverse (subst (cons 10 VRi) (assoc 10 EVK) EVK))
EVK (reverse (subst (cons 10 VLi) (assoc 10 EVK) EVK))
VBR Vri VBL VLi)
(entmod EVK) (entupd VK)
);progn
);if END put into table
(if (= (nth 0 TD-value) "1")
(progn
(setq SSnode (ssadd))
(setq PTX (polar TD0 0 (* H 0.7))
PTY (polar PTX (* pi -0.5) (* H 1.35)))
(entmake (list '(0 . "TEXT") (cons 10 PTX) (cons 11 PTX) (cons 40 H) (cons 1 (strcat "X:"X)) (cons 7 (nth 2 TD-value)) '(72 . 0) '(73 . 1)))
(setq TB (textbox (entget(entlast)))
DIX (distance (car TB) (cadr TB))
PTL (polar PTX 0 (+ DIX (* 0.12 H))))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 PTY) (cons 40 H) (cons 1 (strcat "Y:"Y)) (cons 7 (nth 2 TD-value)) '(72 . 0)))
(setq TB (textbox (entget(entlast))))
(if (< DIX (setq DIY (distance (car TB) (cadr TB))))
(setq PTL (polar PTX 0 (+ DIY (* 0.12 H)))))
(setq SSnode (ssadd (entlast) SSnode))
(setq EPL (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
'(90 . 3) (cons 10 TD0) (cons 10 (polar TD0 0 (* 0.000000001 H))) (cons 10 PTL))))
(setq SSnode (ssadd EPL SSnode))
(if (/= (strcat (nth 4 TD-value) (nth 5 TD-value)) "")
(progn
(setq PTE (polar PTL 0 (+ (* 0.11 Wh) (* 1.5 H))))
(setq name (strcat (nth 4 TD-value) (rtos k 2 0)))
(entmake (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") '(100 . "AcDbEllipse")
(cons 10 PTE) (cons 11 (list (+ (* 0.11 Wh) (* 1.5 H)) 0 0)) (cons 40 (- 0.75 (if (= 0 Wh) 0 0.06)))))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") '(100 . "AcDbEllipse")
'(62 . 8) (cons 10 PTE) (cons 11 (list (+ (* 0.1 Wh) (* 1.4 H)) 0 0)) (cons 40 (- 0.74 (if (= 0 Wh) 0 0.06)))))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 PTE) (cons 11 PTE) (cons 40 H)
(cons 1 name) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))))
(ACET-SS-REDRAW SSnode 2)
(if (not (setq PT1 (ACET-SS-DRAG-MOVE SSnode TD0 "" nil 0)))
(Setq PT1 TD0)
(setq del (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 3) (cons 10 TD0) (cons 10 PT1)))))
(vl-cmdf "move" SSnode "" TD0 PT1)
(ACET-SS-REDRAW SSnode 2)
(if (not (setq ANG (ACET-SS-DRAG-ROTATE SSnode PT1 "" nil 0)))
(if (< (* 0.5 pi) (angle PT1 (cadr (grread 't 15 0))) (* 1.5 pi)) (setq ANG pi) (setq ANG 0)))
(vl-cmdf "erase" del "")
(vl-cmdf "rotate" SSnode "" PT1 (rtos (angle-r2d ANG) 2 2))
(setq SSnode (acet-ss-to-list SSnode))
(if (< (* 0.5 pi) ANG (* 1.5 pi))
(foreach SSn SSnode (if (= (DXF 0 SSn) "TEXT") (rotate-text SSn pi))))
(setq EgPL (entget EPL) EgPL (subst (cons 10 TD0) (assoc 10 EgPL) EgPL))
(entmod EgPL) (entupd EPL)
);progn
(progn
(if (or (not COL) (= 249 COL)) (setq COL 1) (setq COL (1+ COL)))
(progn (grnode TD0 (/ (ACET-GEOM-PIXEL-UNIT) 0.09) COL 90 T nil 0)
(grnode TD0 (/ (ACET-GEOM-PIXEL-UNIT) 0.2) COL 45 T nil 0)))
))
(progn
(setq k (- k 2)
BTX (polar BTX (* 0.5 pi) (* 2 H))
BTY (polar BTY (* 0.5 pi) (* 2 H))
BTT (polar BTT (* 0.5 pi) (* 2 H))
BB1 (polar BB1 (* 0.5 pi) (* 2 H))
BB2 (polar BB2 (* 0.5 pi) (* 2 H))
BR (polar BR (* 0.5 pi) (* 2 H))
BL (polar BL (* 0.5 pi) (* 2 H))
VBR (polar VBR (* 0.5 pi) (* 2 H))
VBL (polar VBL (* 0.5 pi) (* 2 H))))
);if
);while
(prompt "Done\n \U+2022 Statistical coordinates data record - Copyright\U+00A9 2010 Thaistreetz")
(setq TD-value (ACET-LIST-PUT-NTH (rtos k 2 0) TD-value 5)))
;=== Xuat bang toa do coc tu binh do tuyen
(progn
(if (setq SSC (acet-ss-to-list (ssget '((0 . "LINE") (8 . "ENTCOC")))))
(progn
(setq BTR (cadr (grread 't 15 0))
BTL (polar BTR 0 (- (* H -26) Wh))
BT1 (polar BTR 0 (* H -21))
BT2 (polar BTR 0 (* H -10.5))
BB1 (polar BT1 (* 0.5 pi) (* H -2.4))
BB2 (polar BT2 (* 0.5 pi) (* H -2.4))
BR (polar BTR (* 0.5 pi) (* H -2.4))
BL (polar BTL (* 0.5 pi) (* H -2.4))
PTitle (list (- (car BTR) (+ (* 0.5 Wh) (* 13 H))) (+ (cadr BTR) (* 1.8 H)))
BTX (list (- (car BTR) (* 15.75 H)) (+ (cadr BTR) (* -1.2 H)))
BTY (list (- (car BTR) (* 5.25 H)) (+ (cadr BTR) (* -1.2 H)))
BTT (list (- (car BTR) (+ (* 0.5 Wh) (* 23.5 H))) (+ (cadr BTR) (* -1.2 H)))
OV (* H 0.3)
VTR (polar BTR (* 0.25 pi) OV)
VTL (polar BTL (* 0.75 pi) OV)
VBR (polar BR (* 1.75 pi) OV)
VBL (polar BL (* 1.25 pi) OV))
(setq SSnode (ssadd))
(setq VK (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 8) '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 10 VBR) (cons 10 VTR) (cons 10 VTL) (cons 10 VBL)))
SSnode (ssadd (entlast) SSnode))
(setq BK (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 10 BR) (cons 10 BTR) (cons 10 BTL) (cons 10 BL)))
SSnode (ssadd (entlast) SSnode))
(setq B1 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) (cons 10 BB1) (cons 10 BT1)))
SSnode (ssadd (entlast) SSnode))
(setq B2 (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) (cons 10 BB2) (cons 10 BT2)))
SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 PTitle) (cons 11 PTitle) (cons 40 (* 1.2 H)) (cons 1 "%¶ng Täa ®é cäc") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 BTT) (cons 11 BTT) (cons 40 (* 1 H)) (cons 1 "Tªn cäc") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 BTX) (cons 11 BTX) (cons 40 (* 1 H)) (cons 1 "Täa §é X") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 BTY) (cons 11 BTY) (cons 40 (* 1 H)) (cons 1 "Täa §é Y") (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(setq BTX (polar BTX (* -0.5 pi) (* 2.2 H))
BTY (polar BTY (* -0.5 pi) (* 2.2 H))
BTT (polar BTT (* -0.5 pi) (* 2.2 H)))
(prompt "OK Man! ")
(setq SSC (vl-sort SSC '(lambda (EN1 EN2) (< (atof (lytrinh EN1)) (atof (lytrinh EN2))))))
(foreach SSn SSC
(setq TD0 (acet-geom-midpoint (DXF 10 SSn) (DXF 11 SSn))
X (rtos (car TD0) 2 3)
Y (rtos (cadr TD0) 2 3)
STTBTD (tencoc SSn))
(entmake (list '(0 . "TEXT") (cons 10 BTT) (cons 11 BTT) (cons 40 (* 1 H)) (cons 1 STTBTD) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 BTX) (cons 11 BTX) (cons 40 (* 1 H)) (cons 1 X) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(entmake (list '(0 . "TEXT") (cons 10 BTY) (cons 11 BTY) (cons 40 (* 1 H)) (cons 1 Y) (cons 7 (nth 2 TD-value)) '(72 . 1) '(73 . 2)))
(setq SSnode (ssadd (entlast) SSnode))
(setq BTX (polar BTX (* -0.5 pi) (* 2 H))
BTY (polar BTY (* -0.5 pi) (* 2 H))
BTT (polar BTT (* -0.5 pi) (* 2 H)))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) (cons 10 BR) (cons 10 BL)))
(setq SSnode (ssadd (entlast) SSnode))
(setq EB1 (entget B1) EB1 (subst (cons 10 (setq BB1 (polar BB1 (* -0.5 pi) (* 2 H)))) (assoc 10 EB1) EB1))
(entmod EB1) (entupd B1)
(setq EB2 (entget B2) EB2 (subst (cons 10 (setq BB2 (polar BB2 (* -0.5 pi) (* 2 H)))) (assoc 10 EB2) EB2))
(entmod EB2) (entupd B2)
(setq EBK (entget BK)
BRi (polar BR (* -0.5 pi) (* 2 H))
BLi (polar BL (* -0.5 pi) (* 2 H))
EBK (reverse (subst (cons 10 BRi) (assoc 10 EBK) EBK))
EBK (reverse (subst (cons 10 BLi) (assoc 10 EBK) EBK))
BR Bri BL BLi)
(entmod EBK) (entupd BK)
(setq EVK (entget VK)
VRi (polar VBR (* -0.5 pi) (* 2 H))
VLi (polar VBL (* -0.5 pi) (* 2 H))
EVK (reverse (subst (cons 10 VRi) (assoc 10 EVK) EVK))
EVK (reverse (subst (cons 10 VLi) (assoc 10 EVK) EVK))
VBR Vri VBL VLi)
(entmod EVK) (entupd VK))
(acet-ss-redraw SSnode 2)
(setq OTHLAST (getvar "orthomode")) (setvar "orthomode" 0)
(if (setq PT1 (acet-ss-drag-move SSnode BTR "Chon diem dat bang toa do..."))
(vl-cmdf "move" SSnode "" BTR PT1)
(vl-cmdf "erase" SSnode ""))
(setvar "orthomode" OTHLAST)
);progn
));if End Xuat bang toa do coc tu binh do
);if
(command "UCS" "P")
(command "undo" "end")
(princ)
);end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Cập nhật 23:15 .Ps: mình nhầm, nếu đặt tên điểm quá 3 chữ là bị, cái này mình hem pit sữa :D, bạn xem như mình spam đi^^
Hề hề hề,
Cho bạn viên tăng lực nè. Ráng chút nữa coi.
Hãy lưu ý hai dòng code để tạo e lisp bằng hàm (entmake .....) đó.
(entmake (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") '(100 . "AcDbEllipse") (cons 10 PTE) (cons 11 (list (+ (* 0.11 Wh) (* 1.5 H)) 0 0)) (cons 40 (- 0.75 (if (= 0 Wh) 0 0.06)))))
Và đây là mã DXF của đối tượng e lip.
The following group codes apply to ellipse entities. In addition to the group codes described here, see Common Group Codes for Entities. For information about abbreviations and formatting used in this table, see Formatting Conventions in This Reference.
Ellipse group codes
Group codes
Description
100
Subclass marker (AcDbEllipse)
10
Center point (in WCS)
DXF: X value; APP: 3D point
20, 30
DXF: Y and Z values of center point (in WCS)
11
Endpoint of major axis, relative to the center (in WCS)
DXF: X value; APP: 3D point
21, 31
DXF: Y and Z values of endpoint of major axis, relative to the center (in WCS)
210
Extrusion direction (optional; default = 0, 0, 1)
DXF: X value; APP: 3D vector
220, 230
DXF: Y and Z values of extrusion direction (optional)
40
Ratio of minor axis to major axis
41
Start parameter (this value is 0.0 for a full ellipse)
42
End parameter (this value is 2pi for a full ellipse)
Bạn thử dựa vào đây chỉnh sửa lại các giá trị của mã 11, 40 cho phù hợp với kích thước text là OK mà.
Lưu ý tí chút về việc lấy chiều dài của text bằng hàm (textbox.....) hoặc hàm (acet-ent-geomextents ename).
Chúc thành công.
<<
|
Tác giả: 0981474656
Bài viết gốc: 404188
Tên lệnh: vmc |
lisp vẽ mặt cắt từ bình đồ
Lisp vẽ mặt cắt từ bình đồ:
Lệnh VMC.
;; Bien toan cuc deltaH
(defun c:vmc ( /...
>>
Lisp vẽ mặt cắt từ bình đồ:
Lệnh VMC.
;; Bien toan cuc deltaH
(defun c:vmc ( / sel)
(defun luuos ()
(setq
HOANH_OSMODE (getvar "OSMODE")
HOANH_AUTOSNAP (getvar "AUTOSNAP")
)
)
(defun traos ()
(if HOANH_OSMODE
(setvar "OSMODE" HOANH_OSMODE)
)
(if HOANH_AUTOSNAP
(setvar "AUTOSNAP" HOANH_AUTOSNAP)
)
)
(defun GiaoDT (ent1 ent2)
(setq ob1 (vlax-ename->vla-object ent1)
ob2 (vlax-ename->vla-object ent2)
)
(setq g (vlax-variant-value
(vla-IntersectWith ob1 ob2 acExtendNone)
)
)
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
(if g
(progn
(setq kq nil
sd (fix (/ (length g) 3))
)
(repeat sd
(setq kq (append kq (list (list (car g) (cadr g) (caddr g))))
g (cdddr g)
)
)
kq
)
nil
)
)
(defun NhapdeltaH( / tmp)
(while (not tmp)
(setq tmp (getdist "\nVao khoang cach deltaH: "))
(if (not tmp)
(setq tmp deltaH)
)
)
(setq deltaH tmp)
)
;;;---------------------- Main --------------------------------
(princ "\nVMC © CADViet.com")
(if (not deltaH)
(NhapdeltaH)
)
(while (not sel)
(setq sel (entsel "\nVao line mat cat (hoac nhan Enter de nhap deltaH): ")
entl (car sel)
)
(if (not sel)
(NhapdeltaH)
)
)
(if (= "LINE" (cdr (assoc 0 (entget entl))))
(progn
(setq
p (cadr sel)
tt (entget entl)
p1 (cdr (assoc 10 tt))
p2 (cdr (assoc 11 tt))
)
(if (> (distance p p1)
(distance p p2)
)
(setq p p1
p1 p2
p2 p
)
)
(luuos)
(setvar "osmode" 0)
(command ".zoom" p1 p2)
(setq
sspl (ssget "F"
(LIST P1 P2)
'((-4 . "
Hướng dẫn sử dụng:
- Lệnh VMC vẽ mặt cắt của địa hình theo vết cắt cho trước. Địa hình được mô tả bằng các đối tượng pline hay spline có z=0 là đường đồng mức. Vết cắt là một line.
- Khi sử dụng lệnh lần đầu tiên, chương trình sẽ yêu cầu nhập deltaH. Các lần sau, chương trình sẽ không yêu cầu nhập lại deltaH. Muốn hiệu chỉnh giá trị deltaH, bạn nhấn enter khi chương trình hỏi vết cắt.
- Mỗi lần sử dụng, chương trình sẽ yêu cầu chọn 1 line làm vết cắt. Chương trình sẽ vẽ mặt cắt theo vết cắt và deltaH đã chỉ định.")
Anh ơi anh làm ơn hướng dẫn cụ thể hơn cho e được không ạ. sao e làm mãi mà nó ko dc ạ. cái deltaH ấy là gì vậy a? mong anh hồi âm
<<
|
Tác giả: phuhvp
Bài viết gốc: 403111
Tên lệnh: vtx |
Lisp thêm đỉnh cho PL
Đây rồi. Source nguồn của Gilles Chanteau, ket thêm tí muối,lisp áp dụng cho cả Pline có arc và Width thay đổi
>>
Đây rồi. Source nguồn của Gilles Chanteau, ket thêm tí muối,lisp áp dụng cho cả Pline có arc và Width thay đổi
Lệnh vtx.
Update :
Ấn u hoặc Ctrl Z để undo trong quá trình làm việc
Cảm ơn bác Thaistreetz ^^
(defun c:vtx () ;main
(vl-load-com)
(vl-cmdf "undo" "Begin")
(initget "t b T B")
(setq ans (getkword "Th\U+00EAm hay b\U+1EDBt vextex ? "))
(cond ((or(= ans "t")(= ans "T")(not ans))(addvtx))
(T (delvtx))
)
(vl-cmdf "undo" "end")
)
(defun addvtx (/ err AcDoc pl ob pk pa ap typ org
ucs ocs pt sp ep co no p1 p2 pt ce
a1 a2 bu pw wi nw
)
(setq m:err *error*
*error* err
AcDoc (vla-get-activeDocument (vlax-get-acad-object))
os (getvar "osmode")
)
(while
(or(initget "u")
(setq pl (entsel "\nCh\U+1ECDn ph\U+00E2n \U+0111o\U+1EA1n mu\U+1ED1n add th\U+00EAm vertex : ")))
(cond ((or(= pl "u")(= pl "U"))(vl-cmdf "undo" "back"))
(T
(setq ob (vlax-ename->vla-object (car pl)))
(setq typ (vla-get-Objectname ob))
(if (or (= typ "AcDbPolyline")
(and (member typ '("AcDb2dPolyline" "AcDb3dPolyline"))
(= 0 (vla-get-Type ob))
)
)
(progn
(vl-cmdf "undo" "mark")
(setq pk
(if (= typ "AcDb3dPolyline")
(trans (osnap (cadr pl) "_nea") 1 0)
(vlax-curve-getClosestPointToProjection
ob
(trans (cadr pl) 1 0)
(mapcar '-
(trans (getvar "VIEWDIR") 1 0)
(trans '(0 0 0) 1 0)
)
)
)
)
(setq ap (/ (* (getvar "APERTURE")
(getvar "VIEWSIZE")
)
(cadr (getvar "SCREENSIZE"))
)
)
(if (= typ "AcDbPolyline")
(setq co (split-list (vlax-get ob 'Coordinates) 2))
(setq co (split-list (vlax-get ob 'Coordinates) 3))
)
(cond
((equal pk (vlax-curve-getStartPoint ob) ap)
(setq pa 0)
(if (= (vla-get-Closed ob) :vlax-false)
(setq sp (vlax-curve-getStartPoint ob)
ep nil
)
(setq ep nil
sp nil
)
)
)
((equal pk (vlax-curve-getEndPoint ob) ap)
(setq pa (1- (length co)))
(if (= (vla-get-Closed ob) :vlax-false)
(setq ep (vlax-curve-getEndPoint ob)
sp nil
)
(setq ep nil
sp nil
)
)
)
(T
(setq pa (atoi (rtos (vlax-curve-getParamAtPoint ob pk) 2))
ep nil
sp nil
)
)
)
(if (and (/= typ "AcDb3dPolyline")
(or
(not (equal (trans '(0 0 1) 1 0 T)
(setq no (vlax-get ob 'Normal))
1e-9
)
)
(and (= typ "AcDbPolyline")
(/= 0 (vla-get-Elevation ob))
)
(and (= typ "AcDb2dPolyline") (/= 0 (caddar co)))
)
)
(progn
(setq ucs (vla-add
(vla-get-UserCoordinateSystems AcDoc)
(vlax-3d-point (setq org (getvar "UCSORG")))
(vlax-3d-point (mapcar '+ org (getvar "UCSXDIR")))
(vlax-3d-point (mapcar '+ org (getvar "UCSYDIR")))
"addvtxUCS"
)
ocs (vla-add
(vla-get-UserCoordinateSystems AcDoc)
(vlax-3d-Point
(setq org (vlax-curve-getStartPoint ob))
)
(vlax-3d-Point
(mapcar '+ org (trans '(1 0 0) no 0))
)
(vlax-3d-Point
(mapcar '+ org (trans '(0 1 0) no 0))
)
"addvtxOCS"
)
)
(vla-put-activeUCS AcDoc ocs)
)
)
(if (setq
pt
(getpoint (trans (vlax-curve-getPointAtParam ob pa) 0 1)
"\nPick \U+0111i\U+1EC3m th\U+00EAm vertex : "
)
)
(progn
(and ep (setq pa (- (length co) 2)))
(if (/= typ "AcDb3dPolyline")
(progn
(setq p1 (trans (vlax-curve-getPointAtParam ob pa) 0 no)
pt (trans pt 1 no)
p2 (trans (vlax-curve-getPointAtParam ob (1+ pa))
0
no
)
)
(cond
((and ep (/= 0 (vla-getBulge ob pa)))
((lambda (a)
(setq
bu
(list (cons (1+ (fix pa)) (/ (sin a) (cos a))))
)
)
(/
(- (angle p2 pt)
(+ (angle p2 p1)
(* 2 (atan (vla-getBulge ob pa)))
pi
)
)
2.0
)
)
)
((and sp (/= 0 (vla-getBulge ob pa)))
((lambda (a)
(setq
bu (list (cons 0 (/ (sin a) (cos a))))
)
)
(/
(- (+ (angle p1 p2)
(* -2 (atan (vla-getBulge ob pa)))
pi
)
(angle p1 pt)
)
2.0
)
)
)
(T
(setq
ce ((lambda (mid1 mid2)
(inters mid1
(polar mid1
(+ (angle p1 pt) (/ pi 2))
1.0
)
mid2
(polar mid2
(+ (angle pt p2) (/ pi 2))
1.0
)
nil
)
)
(mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))
p1
pt
)
(mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))
pt
p2
)
)
)
(if (or (= 0 (vla-getBulge ob pa)) (null ce))
(setq a1 0.0
a2 0.0
)
(if (< pi
(ang<2pi (- (angle pt p2) (angle p1 pt)))
(* 2 pi)
)
(setq a1 (- (ang<2pi (- (angle ce p1) (angle ce pt)))
)
a2 (- (ang<2pi (- (angle ce pt) (angle ce p2)))
)
)
(setq a1 (ang<2pi (- (angle ce pt) (angle ce p1)))
a2 (ang<2pi (- (angle ce p2) (angle ce pt)))
)
)
)
(setq bu
(list (cons pa (/ (sin (/ a1 4.0)) (cos (/ a1 4.0))))
(cons (1+ (fix pa))
(/ (sin (/ a2 4.0)) (cos (/ a2 4.0)))
)
)
)
)
)
(vla-getWidth ob pa 'sw 'ew)
(cond
((equal pk (vlax-curve-getStartPoint ob) ap)
(setq
pw (+ sw
(/ (* (distance p1 pt) (- ew sw))
(+ (distance pt p1) (distance p1 p2))
)
)
)
)
((equal pk (vlax-curve-getEndPoint ob) ap)
(setq
pw (+ sw
(/ (* (distance p1 p2) (- ew sw))
(+ (distance pt p2) (distance p1 p2))
)
)
)
)
(T
(setq
pw (+ sw
(/ (* (distance p1 pt) (- ew sw))
(+ (distance p1 pt) (distance pt p2))
)
)
)
)
)
(setq wi (list (list pa sw pw) (list (1+ pa) pw ew))
nw (1+ pa)
)
(repeat (- (fix (vlax-curve-getEndParam ob)) (1+ pa))
(vla-getWidth ob nw 'sw 'ew)
(setq wi (cons (list (setq nw (1+ nw)) sw ew) wi))
)
)
)
(cond
((= typ "AcDbPolyline")
(setq pt (list (car pt) (cadr pt)))
)
((= typ "AcDb3dPolyline") (setq pt (trans pt 1 0)))
)
(or sp (setq pa (1+ pa)))
(cond
(sp (setq co (cons pt co)))
(ep (setq co (append co (list pt))))
(T
(setq co (append (sublist co 0 pa)
(cons pt (sublist co pa nil))
)
)
)
)
(or
(= typ "AcDb3dPolyline")
(while (<= (setq pa (1+ pa)) (vlax-curve-getEndParam ob))
(setq bu (cons (cons pa (vla-getBulge ob (1- pa))) bu))
)
)
(vlax-put ob 'Coordinates (apply 'append co))
(or (= typ "AcDb3dPolyline")
(and
(mapcar '(lambda (x) (vla-setBulge ob (car x) (cdr x)))
bu
)
(mapcar '(lambda (x)
(vla-setWidth ob (car x) (cadr x) (caddr x))
)
wi
)
)
)
(and ucs (vla-put-activeUCS AcDoc ucs))
(vla-EndUndoMark AcDoc)
)
)
)
(progn
(alert "Ch\U+1ECDn sai \U+0111\U+1ED1i t\U+01B0\U+1EE3ng!")
(exit)
)
);end if check type
);end T
);end cond
);end while
(and ocs (vla-delete ocs) (setq ocs nil))
(setq *error* m:err
m:err nil
)
(princ)
)
(defun DelVtx (/ err os pt ent typ plst par blst n wlst)
(vl-load-com)
(setq m:err *error*
*error* err
os (getvar "OSMODE")
)
(setvar "OSMODE" 1)
(while
(or (initget "u")
(setq pt
(getpoint
"\nCh\U+1ECDn vertex c\U+1EA7n x\U+00F3a :"
)
))
(cond ((or(= pt "u")(= pt "U"))(vl-cmdf "undo" "back"))
(T
(if (and
(setq ent (ssget pt
'((-4 . "<OR")
(0 . "LWPOLYLINE")
(-4 . "<AND")
(0 . "POLYLINE")
(-4 . "<NOT")
(-4 . "&")
(70 . 118)
(-4 . "NOT>")
(-4 . "AND>")
(-4 . "OR>")
)
)
)
(setq ent (vlax-ename->vla-object (ssname ent 0)))
(setq typ (vla-get-ObjectName ent))
)
(if
(and
(setq plst (if (= typ "AcDbPolyline")
(split-list (vlax-get ent 'Coordinates) 2)
(split-list (vlax-get ent 'Coordinates) 3)
)
)
(< 2 (length plst))
)
(progn
(vl-cmdf "undo" "mark")
(setq pt (trans pt 1 0)
par (cond
((equal pt (vlax-curve-getStartPoint ent) 1e-9)
0
)
((equal pt (vlax-curve-getEndPoint ent) 1e-9)
(1- (length plst))
)
(T
(atoi (rtos (vlax-curve-getParamAtPoint ent pt) 2)
)
)
)
blst nil
wlst nil
n 0
)
(if (/= typ "AcDb3dPolyline")
(progn
(repeat (length plst)
(if (/= n par)
(setq
blst
(cons (cons (length blst) (vla-getBulge ent n))
blst
)
)
)
(setq n (1+ n))
)
(if (/= 0 par)
(progn
(vla-getWidth ent (1- par) 'swid1 'ewid1)
(vla-getWidth ent par 'swid2 'ewid2)
(setq wlst (cons (list (1- par) swid1 ewid2) wlst))
)
)
(repeat
(- (setq n (1- (fix (vlax-curve-getEndParam ent))))
par
)
(vla-getWidth ent n 'swid 'ewid)
(setq
wlst (cons (list (setq n (1- n)) swid ewid) wlst)
)
)
)
)
(vlax-put ent
'Coordinates
(apply 'append (vl-remove (nth par plst) plst))
)
(or (= typ "AcDb3dPolyline")
(and
(mapcar '(lambda (x) (vla-setBulge ent (car x) (cdr x)))
blst
)
(mapcar '(lambda (x)
(vla-setWidth ent (car x) (cadr x) (caddr x))
)
wlst
)
)
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(progn
(alert "\nKh\U+00F4ng th\U+1EC3 x\U+00F3a \U+0111\U+01B0\U+1EE3c, Pline n\U+00E0y ch\U+1EC9 c\U+00F3 1 ph\U+00E2n \U+0111o\U+1EA1n!")
(exit)
)
)
(progn
(alert "Ch\U+1ECDn sai \U+0111\U+1ED1i t\U+01B0\U+1EE3ng!")
(exit)
)
)
);endT
);end cond
)
(setvar "OSMODE" os)
(setq *error* m:err
m:err nil
)
(princ)
)
;;; SUBLIST Return a sub-list
;;;
;;; Arguments
;;; lst : a list
;;; start : start index for the sub-list (first item = 0)
;;; leng : sub-list length (or nil)
;;;
;;; Examples :
;;; (sublist '(1 2 3 4 5 6) 2 2) -> (3 4)
;;; (sublist '(1 2 3 4 5 6) 2 nil) -> (3 4 5 6)
(defun sublist (lst start leng / n r)
(if (or (not leng) (< (- (length lst) start) leng))
(setq leng (- (length lst) start))
)
(setq n (+ start leng))
(repeat leng
(setq r (cons (nth (setq n (1- n)) lst) r))
)
)
;; SPLIT-LIST Split a list into sub-lists
;; Arguments
;; - lst : the list to be splited
;; - num : an integer, the number of items of sub-lists
;; Examples :
;; (split-list '(1 2 3 4 5 6 7 8) 2) -> ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))
(defun split-list (lst n)
(if lst
(cons (sublist lst 0 n)
(split-list (sublist lst n nil) n)
)
)
)
;;; ANG<2PI
;; Transform any angle (in radians) into its equivalent between 0 and 2*pi
(defun ang<2pi (ang)
(if (and (<= 0 ang) (< ang (* 2 pi)))
ang
(ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
)
)
(defun err (msg)
(if (or
(= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ)
(princ (strcat "\nError: " msg))
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(setvar "OSMODE" os)
(setq *error* m:err
m:err nil
)
)
Mong mọi người giúp sao em dùng lisp này cho cad 2005 đc ko ạ, em dùng trên cad 2007 thì ngon lành nhưng qua cad 2005 thì ko được ạ
<<
|
Tác giả: hhhhgggg
Bài viết gốc: 44164
Tên lệnh: ltt |
Lisp làm tròn số ( là Text) trong CAD ???????
Bạn dùng lisp này thử xem. Lệnh LTT:
;;;-------------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget...
>>
Bạn dùng lisp này thử xem. Lệnh LTT:
;;;-------------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun C:LTT( / ss n i oldDimzin e d v S)
(if (not n0) (setq n0 2))
(setq
ss (ssget '((0 . "TEXT,MTEXT")))
n (getint (strcat "\nSo chu so thap phan <" (itoa n0) ">:"))
i 0
oldDimzin (getvar "dimzin")
)
(if n (setq n0 n) (setq n n0))
(setvar "dimzin" 1)
(repeat (sslength ss)
(setq e (ssname ss i))
(if (= (etype e) "MTEXT") (progn
(command "explode" e "")
(setq e (entlast))
))
(setq
d (entget e)
v (atof (cdr (assoc 1 d)))
S (rtos v 2 n)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(setvar "dimzin" oldDimzin)
(princ)
)
;;;-------------------------------------------------------
@Tue_NV
Ssg đã xem lại vấn đề hôm nọ. Trong các system var liên quan, chỉ có dimzin ảnh hưởng trực tiếp, các "thằng" khác không thấy tác dụng gì khi dùng (rtos value 2 n). Có lẽ do số 2 đã xác định kiểu decimal. Nếu vậy, ta cứ "chơi" như trên đơn giản hơn.
ok ! Cảm ơn bác SSG , lisp của bác chạy tốt lắm ! Diễn đàn của mình thật là tuyệt vời !
<<
|
Tác giả: tiendunghoang
Bài viết gốc: 293140
Tên lệnh: tab2exl |
chuyển thống kê thép sang excel
Hề hề hề,
Bạn dùng thử cái này coi sao nhé.
Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán...
>>
Hề hề hề,
Bạn dùng thử cái này coi sao nhé.
Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán mà thôi,nghĩa là chỉ lấy từ cột đường kính trở đi. Các số liệu khác mình thấy không cần thiết nên không mất công lấy làm chi. Còn nếu bạn thấy cần thì hãy tự bổ sung thêm dựa trên cái mình đã làm nhé.
(defun c:tab2exl (/ lst1 lst2 lst3 lst4 lst5 lst6)
(setq ssbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 66 1))))
fn (getfiled "Chon file de save" "" "csv" 1)
fw (open fn "w"))
(foreach bl ssbl
(setq en (entnext bl))
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "ATTRIB")
(cond
((or (= (cdr (assoc 2 (entget bl))) "TK_2") (= (cdr (assoc 2 (entget bl))) "TK_4")
(= (cdr (assoc 2 (entget bl))) "TK_5") (= (cdr (assoc 2 (entget bl))) "TK_6"))
(if (= (cdr (assoc 2 (entget en))) "TL") (setq lst6 (append lst6 (list (cdr (assoc 1 (entget en)))))))
(if (= (cdr (assoc 2 (entget en))) "DT") (setq lst5 (append lst5 (list (cdr (assoc 1 (entget en)))))))
(if (= (cdr (assoc 2 (entget en))) "SLA") (setq lst4 (append lst4 (list (cdr (assoc 1 (entget en)))))))
(if (= (cdr (assoc 2 (entget en))) "SL1") (setq lst3 (append lst3 (list (cdr (assoc 1 (entget en)))))))
(if (= (cdr (assoc 2 (entget en))) "DAI") (setq lst2 (append lst2 (list (cdr (assoc 1 (entget en)))))))
(if (= (cdr (assoc 2 (entget en))) "DK") (setq lst1 (append lst1 (list (cdr (assoc 1 (entget en)))))))
)
( T nil)
)
)
(setq en (entnext en))
)
)
(setq ldata (mapcar 'list lst1 lst2 lst3 lst4 lst5 lst6))
(princ "DK, DAI, SL1, SLA, DT, TL\n" fw)
(foreach data ldata
(setq txt (strcat (nth 0 data) "," (nth 1 data) "," (nth 2 data) "," (nth 3 data) "," (nth 4 data) "," (nth 5 data) ","))
(princ (strcat txt "\n") fw)
)
(close fw)
(princ)
)
Chúc bạn vui.
Quá tuyệt phamthanhbinh ạ, cám ơn bạn nhiều nhé. Nhưng giúp mình sửa lisp để khi quét 1 lần bảng thống kê trên cad thì xuất ra excel đúng thứ tự đi, hiện tại mình dùng lisp của bạn thì thứ tự bị ngược lại, Thanks
<<
|
Filename: 293140_tab2exl.lsp
|
|
Tác giả: Thaistreetz
Bài viết gốc: 422318
Tên lệnh: df |
SỬA GIÚP MÌNH LISP DÙNG HỘP THOẠI DIALOG?
(defun c:df ( / dcl_code dcl_id file_dcl temp)
(if (not>>
(defun c:df ( / dcl_code dcl_id file_dcl temp)
(if (not *canopy*) (setq *canopy* (list "1" "0" "0" "0" "0" "0")))
(setq dcl_code (list (strcat
"canopy : dialog { label = \"&Lisp ve canopy\";"
" : boxed_radio_row { label = \"Select drawing type\"; key = \"dt\";"
" : radio_button { label = \"&Side elevation\"; key = \"se\";}"
" : radio_button { label = \"&Front elevation\"; key = \"fe\";}"
" : radio_button { label = \"&plan\"; key = \"pl\";}}"
" : column {"
" : edit_box { label = \"Roof slope (%)\"; edit_width = 6; key = \"slope\";}"
" : edit_box { label = \"Canopy length\"; edit_width = 6; key = \"length\";}"
" : edit_box { label = \"Canopy width\"; edit_width = 6; key = \"width\";}}"
" ok_cancel;}")))
(setq temp (vl-filename-mktemp "canopy.dcl") file_dcl (open temp "W"))
(foreach l dcl_code (write-line l file_dcl))
(close file_dcl)
(setq dcl_id (load_dialog temp))
(vl-file-delete temp)
(new_dialog "canopy" dcl_id)
(mapcar 'set_tile (list "se" "fe" "pl" "slope" "length" "width") canopy)
(cond ((= (car *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(0 1 0)))
((= (cadr *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(0 0 1)))
((= (caddr *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(1 0 0))))
(action_tile "se" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\") '(0 1 0))")
(action_tile "fe" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\") '(0 0 1))")
(action_tile "pl" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\") '(1 0 0))")
(action_tile "accept" "(setq *canopy* (mapcar 'get_tile '(\"se\" \"fe\" \"pl\" \"slope\" \"length\" \"width\"))) (done_dialog)")
(start_dialog) (unload_dialog dcl_id)
(cond ((= (car *canopy*) "1") (alert "Viet code ve mat cat vao day"))
((= (cadr *canopy*) "1") (alert "Viet code ve mat dung vao day"))
((= (caddr *canopy*) "1") (alert "Viet code ve mat bang vao day")))
(princ))
Đây bạn. Viết hết luôn cho rồi nhé. Nhúng luôn DCL vào lisp luôn. mình toàn viết thế. test các hàm điều khiển DCL tiện hơn.
<<
|
Tác giả: namhai
Bài viết gốc: 65812
Tên lệnh: er2c |
lisp xóa tất cả các đối tượng trong 1 vùng kín
Nanhai à, vì ban đầu bạn chỉ yêu cầu xóa các đối tượng trong 1 curve. Sau đó thì Nanhai yêu cầu thêm xóa các đối tượng >>
Nanhai à, vì ban đầu bạn chỉ yêu cầu xóa các đối tượng trong 1 curve. Sau đó thì Nanhai yêu cầu thêm xóa các đối tượng ngoài 1 curve.
Bây giờ thì yêu cầu thêm xóa các đối tượng giữa 2 curve, chứ không có "hình như" bạn ạ
Thiep sẽ chỉnh sửa Lisp theo cả 3 yêu cầu này cho bạn.
Nhớ lần sau Namhai ra đầu đề 1 lần thôi, khỏi phải viết đi viết lại nhiều lần bạn nhé?
Lisp đã chỉnh sửa:
;; ERC.LSP free lisp from cadviet.com
;; copyright by Thiep,06/2009
;;;----------------------------
(defun ss2ent (ss / i Le e)
(setq i 0
Le nil
)
(repeat (sslength ss)
(setq
e (ssname ss i)
Le (append Le (list e))
i (1+ i)
)
)
Le
)
;;;-----------------------------------
(defun fen (cur / sc glength d l1 p0)
(setq sc 2009
glength (lambda (e) (command ".lengthen" e "") (getvar "perimeter"))
d (/ (glength cur) sc)
l1 0.0
p0 (vlax-curve-getStartPoint cur)
L (list p0)
)
(redraw cur 4)
(repeat sc
(setq
l1 (+ l1 d)
p1 (vlax-curve-getPointAtDist cur l1)
)
(setq L (append L (List p1)))
)
L
)
;;;---------------------------------------------------
(defun c:er2c (/ cur L n ssgDEL glength)
(princ "\nFree lisp from www.cadviet.com")
;-------------------
(acet-error-init
(list
(list "cmdecho" 0 "highlight" 0 "regenmode"
1 "osmode" 0 "ucsicon" 0
"offsetdist" 0 "attreq" 0
"plinewid" 0 "plinetype" 1 "gridmode"
0 "celtype" "CONTINUOUS" "ucsfollow"
0 "limcheck" 0
)
T ;flag. True means use undo for error clean up.
'(if
redraw_it
(redraw na 4)
)
) ;list
) ;acet-error-init
;--------------------
(command "undo" "be")
(setvar "osmode" 0)
(setq n 0)
(initget "T N G")
(setq bit
(getkword
"\nBan muon xoa Trong hay Ngoai 1 Curve, hay giua 2 Curve < T/N/G>: "
)
)
(cond ((= bit "T")
(setq cur (car (entsel "\nChon curve: "))
L (fen cur)
ssgDEL (ssget "WP" L)
)
)
((= bit "N")
(setq cur (car (entsel "\nChon curve: "))
L (fen cur)
ssgDEL (ssget "X")
ssginC (ssget "CP" L)
enssginC (ss2ent ssginC)
)
(foreach eni enssginC
(ssdel eni ssgDEL)
)
)
((= bit "G")
(setq cur1 (car (entsel "\nChon curve ngoai: "))
L1 (fen cur1)
ssgDEL (ssget "WP" L1)
cur2 (car (entsel "\nChon curve trong: "))
L2 (fen cur2)
ssginC2 (ssget "CP" L2)
enssginC2 (ss2ent ssginC2)
)
(foreach eni enssginC2
(ssdel eni ssgDEL)
)
)
)
(repeat (sslength ssgDEL)
(if (and (/= (ssname ssgDEL n) cur2) (/= (ssname ssgDEL n) cur1))
(progn
(entdel (ssname ssgDEL n))
(setq n (1+ n))
)
)
)
(command "undo" "end")
(acet-error-restore)
(princ
"\nChuc cac ban may man va thanh cong - Thiep 0918841230"
)
(princ)
)
(vl-load-com)
Bác Thiếp à,,sory bác vì lúc đầu e chỉ gặp rắc rối với 1 curve, vấn đề về 2 curve là ý tưởng phát sinh mà, hìhì...nhưng sao lisp này không kết hợp được với extrim giống như 1 curve hả bác thiep?nếu kết hợp được với extrim thì tuyệt quá bác thiêp a!Thanks bác nhiều nhiều nha
<<
|
Tác giả: proconeng86
Bài viết gốc: 297104
Tên lệnh: tmp |
lisp tính tổng số đai trong dim
Không nghĩ bạn "quơ" luôn dim không đai.
(defun c:tmp()
(defun GeD(v / l en)
(setq l nil)
...
>>
Không nghĩ bạn "quơ" luôn dim không đai.
(defun c:tmp()
(defun GeD(v / l en)
(setq l nil)
(vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
(cdr (assoc 2 (entget v))))
(if (= "MTEXT" (cdr (assoc 0 (entget (setq en (vlax-vla-object->ename item))))))
(setq l en))
) l
)
(Prompt "\nChon Dim:")
(setq l nil)
(foreach x (acet-ss-to-list (ssget '((0 . "DIMENSION"))))
(setq txt (cdr (assoc 1 (entget (Ged x)))))
(if (and (vl-string-search "[" txt) (vl-string-search "%" txt) (vl-string-search "a" txt))
(setq
sl (atoi (substr txt (+ 2 (vl-string-search "[" txt))
(- (vl-string-search "%" txt) (vl-string-search "[" txt) 1)))
fi (atoi (substr txt (+ 4 (vl-string-search "%" txt))
(- (vl-string-search "a" txt) (vl-string-search "%" txt) 3)))
l (if (not (assoc fi l))
(cons (cons fi sl) l)
(subst (cons fi (+ sl (cdr (assoc fi l)))) (assoc fi l) l))))
)
(if l
(progn
(setq st "")
(foreach x l (setq st (strcat st "\n" (itoa (cdr x)) (chr 216) (itoa (car x)))))
(alert st)))
(princ)
)
Tại vì trong đoạn cột thì không có đai, nếu chọn từng thằng thì tốn nhiều thời gian mà
Lisp này là ok rồi
Cám ơn bạn Tot77 nhiều nhé, bạn nhiệt tình thật đó. khi nào có dịp ra hà nội pm mình nhé, ae giao lưu nha :) :) :)
<<
|
Tác giả: proconeng86
Bài viết gốc: 297091
Tên lệnh: tmp |
lisp tính tổng số đai trong dim
Sửa thêm:
(defun c:tmp()
(defun GeD(v / l en)
(setq l nil)
(vlax-for item (vla-item...
>>
Sửa thêm:
(defun c:tmp()
(defun GeD(v / l en)
(setq l nil)
(vlax-for item (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
(cdr (assoc 2 (entget v))))
(if (= "MTEXT" (cdr (assoc 0 (entget (setq en (vlax-vla-object->ename item))))))
(setq l en))
) l
)
(Prompt "\nChon Dim:")
(setq l nil)
(foreach x (acet-ss-to-list (ssget '((0 . "DIMENSION"))))
(setq txt (cdr (assoc 1 (entget (Ged x))))
sl (atoi (substr txt (+ 2 (vl-string-search "[" txt))
(- (vl-string-search "%" txt) (vl-string-search "[" txt) 1)))
fi (atoi (substr txt (+ 4 (vl-string-search "%" txt))
(- (vl-string-search "a" txt) (vl-string-search "%" txt) 3)))
l (if (not (assoc fi l))
(cons (cons fi sl) l)
(subst (cons fi (+ sl (cdr (assoc fi l)))) (assoc fi l) l)))
)
(setq st "")
(foreach x l (setq st (strcat st "\n" (itoa (cdr x)) (chr 216) (itoa (car x)))))
(alert st)
(princ)
)
Lisp của bạn trước mình chỉ thử với dim bố trí đai rất là ok, tuy nhiên mình vừa dùng lisp của bạn để làm việc, khi chọn lẫn cả những dim thường (dim không bố trí đai) thì lisp của bạn lại bị lỗi gì đó, không tính đai được. Lỗi này trong lisp của bạn phamthanhbinh đã sửa được rồi đó.
Bạn sửa lại giúp mình nốt lần này nhé.
Mình cám ơn nhiều
<<
|
Tác giả: Chiron
Bài viết gốc: 187443
Tên lệnh: laycur 5 |
LISP Cập nhật đối tượng vào layer hiện hành
Mình có lisp này, khi thực hiện lệnh, sẽ cập nhật đối tượng vào layer hiện hành. Nhưng nó chỉ cho phép chuyển layer, còn màu sắc của...
>>
Mình có lisp này, khi thực hiện lệnh, sẽ cập nhật đối tượng vào layer hiện hành. Nhưng nó chỉ cho phép chuyển layer, còn màu sắc của đối tượng vẫn không thay đổi. Mình muốn thêm phần tự động chuyển màu về bylayer khi thực hiện lệnh này. Mong các bạn sửa giúp mình!
Cảm ơn rất nhiều!
;;; ================== Cap nhat doi tuong vao layer hien hanh ==================
(Defun LAYCUR (/ SS CNT LAY) (setvar "cmdecho" 0)
(if (not (setq SS (ssget "i")))
(progn (prompt "\nChon doi tuong cap nhat vao layer hien hanh: ")
(setq SS (ssget)) ) )
(if SS (progn
(setq CNT (sslength SS)) (princ (strcat "\n" (itoa CNT) " Doi tuong tim thay.")) (command "_.move" SS "")
(if (> (getvar "cmdactive") 0)
(progn
(command "0,0" "0,0") (setq SS (ssget "p") CNT (- CNT (sslength SS)) ) )
(setq SS nil) ) (if (> CNT 0)
(princ (strcat "\n" (itoa CNT) " Doi tuong tren layer LOCK.")) ) ) )
(if SS (progn
(setq LAY (getvar "CLAYER")) (command "_.chprop" SS "" "_la" LAY "")
(if (= (sslength SS) 1)
(prompt (strcat "\n1 doi tuong da cap nhat vao layer : " LAY " (layer hien hanh)."))
(prompt (strcat "\n" (itoa (sslength SS)) " doi tuong da cap nhat vao layer : " LAY " (layer hien hanh).")) ) )) (princ) );end
(defun c:LAYCUR () (laycur)) (defun c:5 () (laycur))
Mình nghĩ, không cần dùng tới lisp đâu. Bạn có thể dùng lệnh laycur, đây là lệnh của autocad nên không phải load lisp khác.
<<
|
Filename: 187443_laycur_5.lsp
|
|
Tác giả: toiyeuvietnam
Bài viết gốc: 299111
Tên lệnh: batter |
viết giúp em cái lisp rải mái taluy
Đây nè, cho các bác bộ mã nguồn luôn
Về nghiên cứu thêm nhé
(defun...
>>
Đây nè, cho các bác bộ mã nguồn luôn
Về nghiên cứu thêm nhé
(defun c:batter () (setvar "CMDECHO" 0) (setq osmode (getvar "osmode")) (setvar "osmode" 0) (setvar "unitmode" 0) (setvar "dimzin" 0) (setvar "blipmode" 0) (setvar "aunits" 0) (setvar "angbase" (/ pi 2)) (setvar "angdir" 1) (if (not lint) (setq lint 10.0) ) (setq int (getdist (strcat "\nInterval <" (rtos lint 2 3) ">: "))) (if int (setq lint int) (setq int lint) ) (command "line" (list 0.0 0.0) (list 0.0 0.0001) "") (if (tblsearch "block" "tadtick") (command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "") (command "block" "tadtick" (list 0.0 0.0) (entlast) "") ) (while (setq refent (entsel "\nSelect reference line: ")) (command "undo" "group") (redraw (car refent) 3) (initget 1 "Cut Fill") (setq reply (getkword "\nut or ill batter: ")) (setq s (ssget)) (command "measure" refent "b" "tadtick" "y" int) (setq p (ssget "p") cn 0 ) (if s (progn (while (< cn (sslength p))(setq en (entget (ssname p cn))p0 (cdr (assoc 10 en))pt1 p0pt2 nilb (cdr (assoc 50 en)))(entdel (ssname p cn))(setq p1 (polar p0 (+ (/ pi 2) b ) 0.0001)) (command "line" p0 p1 "") (command "extend" s "" (list (entlast) p1) "") (setq xent (entget (entlast))) (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent))) ) (if (not (equal xdist 0.0001 0.0001)) (setq pt2 (cdr (assoc 11 xent))) (progn (command "extend" s "" (list (entlast) p0) "") (setq xent (entget (entlast))) (setq xdist (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent)) ) ) (if (not (equal xdist 0.0001 0.0001)) (setq pt2 (cdr (assoc 10 xent))) ) ) ) (entdel (entlast)) (if pt2 (if (= reply "Fill") (if (= (rem cn 2) 0) (command "line" pt1 pt2 "") (command "line" pt1 (polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2)) "" ) ) (if (= (rem cn 2) 0) (command "line" pt2 pt1 "") (command "line" pt2 (polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2)) "" ) ) ) ) (setq cn (1+ cn)) ) ) ) (command "undo" "en") ) (setvar "blipmode" 1) (setvar "osmode" osmode) (princ))
==========================================
Nhờ các bác giúp em sửa cái lisp này với:
Yêu cầu:
- gõ BATTER
- chọn đối tượng cần vẽ Taluy (có thể chọn nhiều đối tượng vẽ Taluy 1 lúc)
- pick phía cần dải Taluy
- chọn đối tượng chân Taluy
- xong!
<<
|
Filename: 299111_batter.lsp
|
|
Tác giả: tamkt
Bài viết gốc: 419361
Tên lệnh: merge |
Nâng Cao Lệnh Chia Dim, Nối Dim
Tóm tắt cái lisp trên tí thôi. Không dài dòng các kiểu. Trường hợp đặc biệt là các dim cùng hàng và chân dim dài như nhau...
>>
Tóm tắt cái lisp trên tí thôi. Không dài dòng các kiểu. Trường hợp đặc biệt là các dim cùng hàng và chân dim dài như nhau nhé.
Nghịch thử nhé ^_^
(defun c:merge ()
(if (setq ss (ssget '((0 . "DIMENSION"))))
(progn
(setq lst nil)
(setq pt (cdr (assoc 10 (entget (ssname ss 0)))))
(foreach dim (ssnamex ss)
(if (= 'ename (type (cadr dim)))
(progn
(setq lst (cons (cdr (assoc 13 (entget (cadr dim)))) lst))
(setq lst (cons (cdr (assoc 14 (entget (cadr dim)))) lst))
)
)
)
(setq lst (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))
(command "erase" ss "")
(command "dimrotated"
(RtD (angle (car lst)
(car (reverse lst))
)
)
(car lst)
(car (reverse lst))
pt
)
)
)
(princ)
)
(defun RtD (r) (* 180.0 (/ r pi)))
Cám ơn Anh Bee, quá tuyệt vời.
<<
|
Filename: 419361_merge.lsp
|
|
Tác giả: leejang
Bài viết gốc: 140617
Tên lệnh: chon |
Lisp chọn tất cả các đối tượng thuộc 1 layer !
Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn...
>>
Tại sao những việc đó bạn phải cần đến lisp vậy ^^ Các công cụ qselect, fi làm tốt mà. Còn nếu bạn cần thì đây ^^ Mình vídụ chọn layer 0
(defun c:chon()(sssetfirst nil (ssget "x" '((8 . "0")))))
Đúng rồi. Cảm ơn bác nhiều nhé !hii
<<
|
Filename: 140617_chon.lsp
|
|
Tác giả: Phiphi-
Bài viết gốc: 72551
Tên lệnh: coa |
Xin lisp copy align
Code đây : rất ngắn gọn
(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(command "copy" ss "" '(0 0 0) "@")
(command "align" ss ""...
>>
Code đây : rất ngắn gọn
(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(command "copy" ss "" '(0 0 0) "@")
(command "align" ss "" pause)
(princ)
)
Vẩn sử dụng với mục đích copy MỘT đối tượng rồi align với TỪNG (nhiều) đối tượng khác.
Thay vì phải chọn từng point do lệnh Align yêu cầu, xin Bác Tue_NV viết LISP cho phép chọn LINE trên đối tượng copy (tức là chọn được 2 điểm endpoints) rồi align vào CÁC đối tượng khác cũng bằng cách chọn các LINE trên các đối tượng cần Align.
Như vậy sẽ giảm rất nhiều lần phải Specify... point.
Thank you Bác nhé.
<<
|
Tác giả: phamthanhbinh
Bài viết gốc: 77447
Tên lệnh: dcap |
Nhờ Giúp Lisp Đánh Cấp
Bạn thử Lisp này Tue_NV viết thử xem : Bài toán : cho 1 Polyline -> vẽ đường đánh cấp với bề rộng là B như file bạn gửi kèm theo
(defun...
>>
Bạn thử Lisp này Tue_NV viết thử xem : Bài toán : cho 1 Polyline -> vẽ đường đánh cấp với bề rộng là B như file bạn gửi kèm theo
(defun c:dcap();(/ curve B sp ep Lx n po1 po2 po3 i oldos)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq curve (car(entsel "\n Ban Pick chon Pline :")) ss (ssadd))
(setq B (getdist "\n Nhap be rong danh cap :"))
(setq sp (vlax-curve-getStartPoint curve))
(setq ep (vlax-curve-getEndPoint curve))
(if (> (cadr sp) (cadr ep))
(progn
(setq ep (vlax-curve-getStartPoint curve))
(setq sp (vlax-curve-getEndPoint curve))
))
(setq Lx (abs (- (car ep) (car sp)) ))
(setq n (abs(fix (/ (- Lx (rem Lx B )) B ))) i 1)
(setq po1 sp)
(Repeat n
(setq dvi (list (+ (car sp) (* i B )) (cadr sp) 0))
(command "Xline" "Ver" dvi "")
(setq po3 (car (giaodt curve (entlast))) )
(setq po2 (list (car po3) (cadr po1) 0))
(entdel (entlast))
(dline po1 po2)
(dline po2 po3)
(setq po1 po3)
(setq i (1+ i))
)
(setq po2 (list (car ep) (cadr po1) 0))
(dline po1 po2)
(dline po2 ep)
(setvar "osmode" oldos)
(command "undo" "end")
(princ)
)
;
(defun dline(p1 p2)
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
;
(defun GiaoDT (ent1 ent2)
(setq ob1 (vlax-ename->vla-object ent1)
ob2 (vlax-ename->vla-object ent2)
)
(setq g (vlax-variant-value
(vla-IntersectWith ob1 ob2 acExtendNone)
)
)
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
(if g
(progn
(setq kq nil
sd (fix (/ (length g) 3))
)
(repeat sd
(setq kq (append kq (list (list (car g) (cadr g) (caddr g))))
g (cdddr g)
)
)
kq
)
nil
)
)
Hiện nay chức năng download Lisp file của diễn đàn bị lỗi. Nếu bạn sử dụng chức năng download Lisp file của diễn đàn bị lỗi thì hãy nhấn nút Reply bài viết này của Tue_NV -> chép hết code về (không sót đấy nhé về chạy thử là được
Chúc thành công :tongue2:
Bác Tue_NV ơi,
Cái đoạn code này có ý nghĩa gì vậy???
(setq n (fix (/ (- Lx (rem Lx "http://img2.cadviet.com/forum/style_emoticons/default/cool.gif" style="vertical-align: middle;" emoid="B)" alt="cool.gif" border="0">) "http://img2.cadviet.com/forum/style_emoticons/default/cool.gif" style="vertical-align: middle;" emoid="B)" alt="cool.gif" border="0">) i 1)
Có phải là do lỗi của trang upload không bác?? Nếu vậy bác cho xin lại cái code gốc của bác được không ạ.??? Cám ơn bác nhiều.
<<
|
Tác giả: VUVUZELA
Bài viết gốc: 111537
Tên lệnh: proxy dxf name |
Có cách nào lấy dữ liệu và chỉnh sửa đối tượng PROXY
Bạn load file Proxy LispFunction, giải nén file Proxy_Info.dll vào ổ cứng (Vd : c:\). Gọi lệnh Netload rồi chọn file Proxy_Info.dll vừa bung nén ở buớc trên.
Tham khảo : http://www.cadviet.com/forum/index.php?sho...st&p=111477
Để lấy thông tin của Proxy, trong LISP gọi hàm (Proxy_Info ename)
kết quả nhận đuợc là 1 danh sách các thông tin của Proxy :
- ("\"Harmony\"" "HsCellInforObj" "HS_CELLINFOROBJECT")
- ("\"Harmony\"" "HsNodeObj" "HS_NODEOBJECT")
- hoặc" Entity không phải là Proxy."
hay chạy lisp sau :
;- thông tin của Proxy
(defun C:proxy(/ e)
(if (setq e (entsel "\nSelect object:"))
(princ (vl-prin1-to-string (Proxy_Info (car e)) )) )
(princ) )
;- DXF name của Proxy
(defun C:DXF_name(/ e)
(if (setq e (entsel "\nSelect object:"))
(princ (last (Proxy_Info (car e)) )) )
(princ) )
Chưa thử được đại ka ơi
Vô Cad bấm lệnh NETLOAD thì nó không hiểu
Chắc là phải cài Microsoft Visual C# hả đại ka
Cái này ở đâu có thế
Trong AutoCad 2004 sao em không thấy
<<
|
Filename: 111537_proxy_dxf_name.lsp
|
|
Tác giả: vantuan18nd
Bài viết gốc: 187392
Tên lệnh: tl3 |
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn
Bạn đã đọc nội quy, vậy hãy cố cho code vào thẻ code nhé. Lần đầu này mình sửa hộ bạn
(defun c:tl3 (/)...
>>
Bạn đã đọc nội quy, vậy hãy cố cho code vào thẻ code nhé. Lần đầu này mình sửa hộ bạn
(defun c:tl3 (/) (vl-load-com)
(vla-addtext
(vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(rtos (getdist (getpoint "\nP1 :") "\nP2 :") 2 2)
(vlax-3d-point (getpoint "\nDiem dat KQ :"))
(* (getvar "dimtxt")(getvar "dimscale"))
)
(princ))
Cảm ơn nhé . mình đang rất cần. Đúng ý mình rùi đấy
<<
|
Tác giả: oizdoi_oi
Bài viết gốc: 56104
Tên lệnh: brt |
Hỏi về lệnh Break
Lỗi tại bạn không nói rõ. Khi chạy Lisp hỏi sẽ chọn pick điểm 1 và điểm 2. Điểm 1 và điểm 2 tạo thành 1 cửa sổ (W). Cửa sổ (W) là một hình chữ nhật tạo bởi 2...
>>
Lỗi tại bạn không nói rõ. Khi chạy Lisp hỏi sẽ chọn pick điểm 1 và điểm 2. Điểm 1 và điểm 2 tạo thành 1 cửa sổ (W). Cửa sổ (W) là một hình chữ nhật tạo bởi 2 điểm 1 và điểm 2. Đoạn thẳng nối điểm 1 và điểm 2 chính là đường chéo của hình chữ nhật (W)
Chọn đối tượng là Line, Polyline thẳng.
Lisp sẽ break đối tượng.
Các đối tượng nằm trong vùng cửa sổ (W) bị break. còn đối tượng nằm ngoài cửa sổ được giữ nguyên
Nếu điểm 1 và điểm 2 cùng nằm trên 1 đường thẳng thì Lisp sẽ Break tại 1 điểm.
Bạn chạy thử xem nhé.
(Defun c:brt(/ aL bL cL dL eL fL gL sL hL ss n)
(vl-load-com)
(prompt "\n Chon duong cat bang cach chon diem thu nhat va diem thu hai :")
(setq aL (getpoint "\n Chon diem thu nhat :"))
(setq bL (getcorner aL "\n Chon diem thu hai :"))
(setq fL (list (car aL) (cadr bL) 0))
(setq gL (list (car bL) (cadr aL) 0))
(grdraw aL gL 1 1)
(grdraw gL bL 1 1)
(grdraw bL fL 1 1)
(grdraw fL aL 1 1)
(Prompt "\n Chon doi tuong Line can break tai 1 diem :")
(Setq ss (ssget '((0 . "LINE,LWPOLYLINE"))))
(Setq n (sslength ss)
i 0)
(while (< i n)
(setq sL (ssname ss i))
(setq cL (vlax-curve-getStartPoint sL))
(setq dL (vlax-curve-getEndPoint sL))
(setq eL (inters aL fL cL dL T))
(setq hL (inters bL gL cL dL T))
(if (= eL nil) (setq i (1+ i)))
(if (/= eL nil)
(progn
(Command "_Break" sL eL hL)
(setq i (1+ i))
)
)
)
(Princ)
)
Hy vọng bạn hài lòng.
Chúc thành công :cheers:
OK OK OK
đúng i' rui đấy thank nhìu nhé
<<
|
Tác giả: NDBNGO
Bài viết gốc: 104443
Tên lệnh: ftext |
Viết giúp Lisp xoá text trong khoảng nhất định
Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2...
>>
Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2 file (Txt hoặc CSV)
Cách sử dụng :
gõ lệnh : Ftext (Filter Text)
- chọn Text
- nhập k/cách
- nhập tên Layer chứa Text cần lọc (nếu layer chưa có, lisp sẽ tạo mới)
- chọn tên file xuất Text gốc, Lisp sẽ tự tao file chứa Text cần lọc với qui tắc : tên file gốc + _filter
vd : tên file gốc là Cadviet.csv -> tên file chứa Text cần lọc : Cadviet_filter.csv
Hy vọng hữu ích với bạn.
;Filter Text
(defun c:FText (/ ent ent1 fil fil1 flag j kc newlayer pos ss ss1 str str1 ss_tmp tmp tmp1)
;|By Gia Bach 2010|;
(command "_.undo" "be")
(setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd))
(or kc1 (setq kc1 5))
(setq kc (getreal (strcat "\nNhap khoang cach : <" (rtos kc1) ">")))
(if (= kc nil) (setq kc kc1) (setq kc1 kc))
(while (> (sslength ss) 0)
(setq ent (ssname ss 0)
pos (cdr (assoc 10 (entget ent)))
ss (ssdel ent ss)
ss_tmp ss
flag nil)
(setq j -1)
(while (setq ent1 (ssname ss_tmp (setq j (1+ j))))
(if (<= (distance pos (cdr (assoc 10 (entget ent1)))) kc)
(setq flag t
str1 (append (list (cdr (assoc 1 (entget ent1)))) str1)
ss1 (ssadd ent1 ss1)
ss (ssdel ent1 ss)) ) )
(if flag
(setq ss1 (ssadd ent ss1)
str1 (append (list(cdr (assoc 1 (entget ent)))) str1))
(setq str (append (list(cdr (assoc 1 (entget ent)))) str)) ) )
(if (> (sslength ss1) 0)
(progn
(setq newlayer (getstring t "\nNhap ten layer chua Text can filter :"))
(if (not (tblsearch "layer" newlayer))
(command "-layer" "n" newlayer"") )
(command "change" ss1 "" "p" "la" newlayer "")
(if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
(setq fil (open tmp "w") )
(foreach txt str
(write-line txt fil) )
(close fil)
(setq tmp1 (strcat (vl-filename-directory tmp) "\\"
(vl-filename-base tmp) "_filter"
(vl-filename-extension tmp))
fil1 (open tmp1 "w"))
(foreach txt str1
(write-line txt fil1) )
(close fil1) )) ))
(command "_.undo" "e")
(princ))
Đã test chương trình của bạn,nhưng bạn xem lại chương trình xóa khiếp quá ,nhiều chỗ del hêt luôn ,không còn điểm nào.
File xuât ra phải có dạng là 4 cột: N0(Thứ Tự) X (Tọa độ X) Y (Tọa dộ Y) H (Độ cao- text trên màn hình).
<<
|
Filename: 104443_ftext.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 422409
Tên lệnh: ve |
vẽ đường polyline nối tâm của các hình tròn với nhau
Bác @Danh Cong sort ...1e-8 mà không set osmode + command thì dễ dính đạn lắm í nha :D
Tiện thể đang rảnh, luyện thêm mấy cái vl.. lung tung nên em cũng xim góp thêm 1 tí cho xôm tụ & cũng nhờ mấy bác chém cho vài nhát để...
>>
Bác @Danh Cong sort ...1e-8 mà không set osmode + command thì dễ dính đạn lắm í nha :D
Tiện thể đang rảnh, luyện thêm mấy cái vl.. lung tung nên em cũng xim góp thêm 1 tí cho xôm tụ & cũng nhờ mấy bác chém cho vài nhát để nhớ bài kẻo lâu nay ko học thêm được gì cả ^^
(defun c:VE( / ATTBLK ATTBLK_NAME ATT_LST I LST_CEN LST_CEN_SORT LST_POINT LST_SS LST_VA OLD SS STR STR1)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(vl-load-com)
(prompt "\nQuet chon !")
(setq ss (ssget '((0 . "CIRCLE"))))
(prompt "\nChon block ATT can chen !")
(setq AttBlk (ssget "+.:E:S" '((0 . "INSERT") (66 . 1))))
(if (and ss AttBlk)
(progn
(setq #stt (NGT #stt 1 getint "Nhap so thu tu dau"))
(setq start (getvar 'millisecs))
(setq AttBlk (vlax-ename->vla-object (setq AttBlk_name (ssname AttBlk 0)))
Att_lst (GetAtts AttBlk)
str (cdr (car Att_lst))
str1 (substr str 1 (1+ (vl-string-position (ascii "-") str)))
)
(setq lst_ss (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
lst_cen (mapcar '(lambda (x) (H:GetCenter x)) lst_ss)
)
(setq lst_cen_sort (vl-sort lst_cen '(lambda (p1 p2)
(if (equal (cadr p1) (cadr p2) 1E-8)
(< (car p1) (car p2))
(> (cadr p1) (cadr p2))))
)
)
;-----------
(setq i -1)
(foreach PP lst_cen_sort
(setq Lst_point (cons (cons 10 PP) Lst_point)
i (1+ i))
(command ".copy" AttBlk_name "" (H:GetInsertPoint AttBlk) PP)
(SetAtts (vlax-ename->vla-object (entlast)) (list (cons (car (car Att_lst)) (strcat str1 (itoa (+ i #stt))))))
)
(setq Lst_point (reverse Lst_point))
(MakeLWPolyline_db nil nil nil nil)
(princ (strcat "\nThoi gian thuc hien " (rtos (- (getvar 'millisecs) start)) "millisecs"))
)
(princ "* * * Dau vao chua dung * * * !")
)
(mapcar 'setvar lst_va old)
(princ)
)
;======================
;=======================================
(defun H:GetCenter (cir_Obj)
(vlax-safearray->list (vlax-variant-value (vla-get-center cir_Obj)))
)
;=======================================
(defun H:GetInsertPoint (ins_Obj)
(vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint ins_Obj)))
)
;======================================
(defun MakeLWPolyline_db (Linetype LTScale Layer Color / Lst)
(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 6 (if Linetype Linetype "bylayer"))
(cons 48 (if LTScale LTScale 1))
(cons 62 (if Color Color 256))
'(100 . "AcDbPolyline")
(cons 90 (length Lst_point))
(cons 70 0)))
(setq Lst (append Lst Lst_point))
(entmakex Lst)
)
;===================================
(defun SetAtts (Obj Lst / AttVal)
(mapcar '(lambda (Att) (if (setq AttVal (cdr (assoc (vla-get-TagString Att) Lst))) (vla-put-TextString Att AttVal))) (vlax-invoke Obj 'GetAttributes))
(vla-update Obj)
)
;--------------------
(defun GetAtts (Obj)
(mapcar '(lambda (Att) (cons (vla-get-TagString Att) (vla-get-TextString Att))) (vlax-invoke Obj 'GetAttributes))
)
;=====================================
(defun NGT (a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
(modul)
(a)
)
)
)
;=================================
<<
|