hiepttr

Tháng 11 13, 2015

Bạn dùng thử cái này:

p/s: Bạn nên sửa tiêu đề trước khi bịi mod xóa bài :D

;Xuat X tuong doi va Y tuyet doi cua polyline
(defun c:XUAT( / ss lst_name fn pw i ename TT)
(vl-load-com)
(prompt "\nChon PL !")
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(cond 
	(ss
		(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
		(setq pw (open fn "w"))
		(write-line "STT PL,Ten dinh,Y _tuyet doi,X _tuong doi" pw)
		(setq i 0)
		(while (< i (length lst_name))
			(setq	ename (nth i lst_name)
					i (1+ i)
					lst_ver (acet-geom-vertex-list ename)
					)
			(write-line (setq TT (itoa i)) pw)
			(MakeText (car lst_ver) TT 1 0 "C" nil "Lay_Lsp_XUAT" 2 nil)
			(foreach pnt lst_ver
				(write-line (strcat "," (rtos (1+ (vl-position pnt lst_ver))) "," (rtos (cadr pnt) 2 2) "," (rtos (- (car pnt) (car (car lst_ver))) 2 2)) pw)
			)
		)
	)
)
(close pw)
(alert (strcat "Da them " (itoa (length lst_name)) " Text STT PL vao ban ve !"))
(princ)
)
;===================================|;
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial	
(setq Lst (list '(0 . "TEXT")
				(cons 8 (if Layer Layer (getvar "Clayer")))									
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 Height)									
				(cons 1 string)									
				(if Ang (cons 50 Ang))									
				(cons 7 (if Style Style (getvar "Textstyle")))									
				(cons -3 (if xdata (list xdata) nil)))				
				justify (strcase justify))	
				(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))				
					  ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))				
					  ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))				
					  ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))				
					  ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))					
					  ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))				
					  ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))				
					  ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))				
					  ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
					  )	
					  (entmakex Lst)
);end

Tháng 11 12, 2015

1; 2. Không bàn nữa :D

3. Đã fix :

(defun c:DONG4 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Ten coc,Trai,,,Phai" pw)
(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
(foreach c coc
	(setq ten_coc	(cdr 
						(car
							(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
						)
					)
	)
	(setq 	mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c))
			trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object c)) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
			phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
	)
	(command "_.insert" "cocmoc" trai 1 "" "")
	(command "_.insert" "cocmoc" phai 1 "" "")
	(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
	(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
	(write-line (strcat "," ten_coc "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
									"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)
;;;;
(defun H:inter-group3(ob1 ob2 / modul res)
(cond 
	((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
	((= (length modul) 3) (list modul))
	(t 
		(while (> (length modul) 0)
			(setq	res (cons (list (car modul) (cadr modul) (caddr modul)) res)
					modul (cdddr modul)
			)
		)
		(reverse res)
	)
)
)

Tháng 11 12, 2015

- Mình vẫn nối bằng F với R=0 được mà !? :D Chắc là điểm pick của bạn đúng ngay đoạn line "quay đầu trở lại" :D

Nhưng thôi, bạn đã có overkill ...

- Mình đã nói là thứ tự cọc xuất ra phụ thuộc và thứ tự các line ENTCOC khi chọn đối tượng, vì trong thuật toán mình viết, mỗi lần xét giao để đóng cọc mốc chỉ xét cho 1 line ENTCOC và 1 đường biên nên cái "thứ tự này" nó ko liên quan gì đến overkill.

Bạn không tin, có thể thử chọn tùm lum thứ tự cọc xem nó xuất ra thế nào ??? :D :D :D

- Lisp chạy lỗi ko phải do điểm gấp khúc mà do có 1 line ENTCOC tại TD98 không giao với MEPTLP, bạn chỉ cần EXTEND đường MEPTLP ra để có điểm giao là OK !

Tháng 11 11, 2015

Mình đã thử nối PL của bạn, lường trước rằng bạn sẽ bị vướng chổ này nên mới có đoạn: "Nếu góc tạo bởi 2 "cạnh" đầu-cuối của 2 PL = k*pi thì phải chọn 1 trong 2 và "cạnh" tiếp theo ..."

Có nghĩa là bạn Fillet với R=0, 2 điểm chọn tại 2 point như file đính kèm

Có lẻ là do mình diễn giải chưa được rõ :D :D :D

http://www.cadviet.com/upfiles/5/80156_note.dwg

Tháng 11 11, 2015

- ...góc của 2 cạnh đầu cuối PL = k*pi ... Có nghĩa là 2 "cạnh" này nằm trên một đường thẳng >>> Khi đó lệnh FILLET của cad không thực hiện được (đúng ý đồ).

- Nói vẽ đường tim chỉ là cách nói cho dễ hiểu, thực chất là phương thức chọn Fence (hàng rào), cad sẽ chọn lần lượt từ đầu đến cuối các đối tượng mà đường "gạch gạch" cắt qua >>>> không cần vẽ đúng vị trí đường tim mà vẽ sao cho đường "gạch gạch" cắt qua các line ENTCOC là được.

Tháng 11 11, 2015

Vấn đề của bạn được giải quyêt như sau:

- Nếu không join được thì có thể F với R=0, chú ý chọn đúng "cạnh" của PL. Nếu góc tạo bởi 2 "cạnh" đầu-cuối của 2 PL = k*pi thì phải chọn 1 trong 2 và "cạnh" tiếp theo ...

- Sau khi đã join thành công rồi, chạy lisp, chọn 2 đường mép taluy xong, chọn tùy chọn F rồi "vẽ" theo đường tim để lisp xuất cọc đúng thứ tự.

Chúc bạn thành công ! :D

Tháng 11 10, 2015

Tại sao bạn không join đường mép taluy lại thành 1 đối tượng trước khi chạy lisp ?! Như vậy có lạm dụng lisp quá chăng ?!

Tháng 11 10, 2015

- Bạn có thể dùng lisp này, 2 trong 1 :D

(defun c:DONG3 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Ten coc,Trai,,,Phai" pw)
(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
(foreach c coc
	(setq ten_coc	(cdr 
						(car
							(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
						)
					)
	)
	(setq trai (if (= 3 (length (setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity))))
					trai
					(list (car trai) (cadr trai) (caddr trai))
				)
		  phai (if (= 3 (length (setq phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity))))
					phai
					(list (car phai) (cadr phai) (caddr phai))
				)
		  mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
	(command "_.insert" "cocmoc" trai 1 "" "")
	(command "_.insert" "cocmoc" phai 1 "" "")
	(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
	(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
	(write-line (strcat "," ten_coc "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
									"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)

Tháng 11 10, 2015

- Mình chỉ code lúc rảnh và ngoài việc giúp bạn ra nó còn giúp mình ôn bài :D nên nếu hài lòng bạn chỉ cần kích like là đủ :D :D :D

- File xuất ra, bạn mở bằng excel, và nhớ cài đặt dấu ngắt phần thập phân là dấu chấm. Biểu mẫu file mình không theo ý bạn 100%, mình để chừa cột STT lại để bạn làm bằng excel thì linh động hơn, cột Y mình để trước, X để sau, thuận lợi trong việc nhập máy toàn đạc ...

p/s:

- Chú ý, Tên cọc được lấy từ XData của line ENTCOC nên trong quá trình biên tập bình đồ bạn không nên copy line của cọc này sang cọc kia, Hoặc thay đổi tên cọc trên Text thì lisp cũng không nhận được !

- Mình có sửa chút ít để lisp dim đúng form của bạn và không bị lỗi khi line ENTCOC cắt mỗi đường biên > 1 điểm.

(defun c:DONG3 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Tencoc,Y,X" pw)
(foreach c coc
	(setq ten_coc	(cdr 
						(car
							(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
						)
					)
	)
	(setq trai (if (= 3 (length (setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity))))
					trai
					(list (car trai) (cadr trai) (caddr trai))
				)
		  phai (if (= 3 (length (setq phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity))))
					phai
					(list (car phai) (cadr phai) (caddr phai))
				)
		  mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
	(command "_.insert" "cocmoc" trai 1 "" "")
	(command "_.insert" "cocmoc" phai 1 "" "")
	(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
	(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
	(write-line (strcat "" "," "P-" ten_coc "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
	(write-line (strcat "" "," "T-" ten_coc "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)

Tháng 11 7, 2015

-Nét liền = "Continuous"

-Nét tâm = "CENTER,CENTER2,CENTERX2"

-Còn lại là nét đứt

(defun c:TRL ( / cmd ss lst info dxf6 dxf62)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(if ss
	(progn
		(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
		(foreach elem lst
			(cond	((or (and (null (assoc 6 (setq info (entget elem))))
							(wcmatch (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 info)))))) "Continuous")
						)
						(and (assoc 6 info) (wcmatch (cdr (assoc 6 info)) "Continuous"))
					)
						(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
						(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
						(setq info (subst (cons 8 "STEEL") (assoc 8 info) info))
						(entmod info)
					)
					((or (and (null (assoc 6 info))
							(wcmatch (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 info)))))) "CENTER,CENTER2,CENTERX2")
						)
						(and (assoc 6 info) (wcmatch (cdr (assoc 6 info)) "CENTER,CENTER2,CENTERX2"))
					)
						(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
						(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
						(setq info (subst (cons 8 "GRID LINE") (assoc 8 info) info))
						(entmod info)
					)
					(T  
						(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
						(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
						(setq info (subst (cons 8 "HIDDEN LINE") (assoc 8 info) info))
						(entmod info)
					)
			)
		)
	)
	(princ "\n*** Khong chon duoc thang nao ca ^|^ ***")
)
(setvar "cmdecho" cmd)
(princ)
)

Tháng 11 6, 2015

Hình như hôm nay chổ bác Bình trời mát thì phải :D

Nếu như những hôm khác, cứ tình hình trình bày, diễn giải câu hỏi như này thì chắc cú là bị mắng mỏ, hoặc xấu hơn là bị xóa bài rồi đó :D

p/s:

Góp ý với thớt:

Nếu bảng trình bày "lung tung" không theo quy luật thì bạn có thể "mách nước" cho chúng tôi biết là bạn có thể tìm và thống kê các cặp text theo "quy luật" nào ?! :D

Phải chăng text "SIZE" luôn căn lề Midlle, cách [các con số thống kê size VD: "(101+237)x450" ) luôn có dạng *x*, căn lề Midlle left ] theo phương ngang là 370

Và tương tự giữa "SIZE" và cột "hình như là số lượng" :D là 535

Tháng 11 6, 2015

Thể dục buổi sáng giúp bạn đây :D

(defun c:xoay ( / cmd ss ename info dxf10 dxf11)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(prompt "\nChon (cac) LINE muon xoay 180 do !")
(setq ss (ssget '((0 . "LINE"))))
(if ss
	(repeat (sslength ss)
		(setq info (entget (setq ename (ssname ss 0)))
			  dxf10 (cdr (assoc 10 info))
			  dxf11 (cdr (assoc 11 info))
			  info (subst (cons 10 dxf11) (assoc 10 info) info)
			  info (subst (cons 11 dxf10) (assoc 11 info) info)
		)
		(entmod info)
		(ssdel ename ss)
	)
(alert "\n*** Khong chon duoc thang nao ca ^|^ ***")
)
(setvar 'cmdecho cmd)
(princ)
)

Tháng 11 4, 2015

Nút enter chứ ko phải space

Tháng 11 4, 2015

Có thể lỗi do code cũ hay ... mình không muốn "đột nhập" :D

Chỉ có thể sửa cho bạn thế này thôi :

(defun c:rpl2()
    (setq olsosmode (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (setq p (ssget))  
    (if p
 (progn
            (setq osl (strlen (setq os (H:get-string "Old string "))))
            (setq nsl (strlen (setq ns (H:get-string "New string "))))
     (setq l 0 chm 0 n (sslength p))
     (setq adj
  (cond
      ((/= osl nsl) (- nsl osl))
      (T nsl)
  )
     )
 (while (< l n)                  
     (setq d (entget (setq e (ssname p l))))
     (if (and (= (atext 0) "INSERT")(= (atext 66) 1))
  (progn
      (setq e (entnext e))
      (while e
   (setq d (entget e))
   (cond
       ((= (atext 0) "ATTRIB")
    (setq chf nil si 1)
    (setq s (cdr (setq as (assoc 1 d))))
    (while (= osl (setq sl (strlen
        (setq st (substr s si osl)))))
        (cond
     ((= st os)
         (setq s (strcat (substr s 1 (1- si)) ns
         (substr s (+ si osl))))
         (setq chf t)
         (setq si (+ si adj))
     )
        )
    (setq si (1+ si))
       )
       (if chf
    (progn       
        (setq d (subst (cons 1 s) as d))
        (entmod d)       
        (entupd e)       
        (setq chm (1+ chm))
    )
       )
       (setq e (entnext e))
       )
       ((= (atext 0) "SEQEND")
    (setq e nil))
       (T (setq e (entnext e)))
                        )
      )
  )
     )
            (if (= "MTEXT"            ; Look for MTEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (if (= "DIMENSION"            ; Look for DIMENSION entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (if (= "TEXT"            ; Look for TEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
     (setq l (1+ l))
 )
 )
    )
    (if (> chm 1)
       (princ (strcat "\nUpdated " (itoa chm) " text strings"))
       (princ (strcat "\nUpdated " (itoa chm) " text string"))
    )
    (setvar "OSMODE" oldosmode)
    (terpri)
)
;
(defun atext (num)
   (cdr (assoc num d))
)
;;==================
(defun H:get-string(show /  str text)
 (cond ((> (strlen (setq str (getstring (strcat "\n" show " <Pick>: ") T))) 0) str)
    ((while (not text)
    (prompt "\nPick: ")
    (setq text (ssget "+.:E:S" '((0 . "*TEXT"))))
    )
   (setq str (cdr (assoc 1 (entget (ssname text 0))))))
 )
)

Tháng 11 3, 2015

Không có file để thử, nhưng bạn thử thay dòng:

(setq nsl (strlen (setq ns (getstring "\nNew string: " t))))
bằng:

(setq nsl (strlen (setq ns (H:get-string))))

Và thêm đoạn:

(defun H:get-string( / str text)
(cond ((> (strlen (setq str (getstring "\nNew string <Pick>: " T))) 0) str)
    ((while (not text)
    (prompt "\nPick: ")
    (setq text (ssget "+.:E:S" '((0 . "*TEXT"))))
    )
   (setq str (cdr (assoc 1 (entget (ssname text 0))))))
)
)

vào cuối lisp

==>>> Khi dùng, muốn chọn text thì enter

Tháng 11 2, 2015

Pro thì không dám nhưng cũng sửa cho bạn đây: :D :D :D

(defun c:DONG2 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(foreach c coc
	(setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity)
		  phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity)
		  mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
	(command "_.insert" "cocmoc" trai 1 "" "")
	(command "_.insert" "cocmoc" phai 1 "" "")
	(command ".DIMALIGNED" mid_pt trai mid_pt)
	(command ".DIMALIGNED" mid_pt phai mid_pt)
)
(mapcar 'setvar lst_va old)
(princ)
)

Tháng 10 31, 2015

Đưa : (command "_change" en "" "p" "c" "1" "")

lên 8 dòng liền sau (while...)

Tháng 10 31, 2015

Có lẻ chủ thớt thắc mắc như trên là do:

- Khoảng cách điều kiện trong lisp được tính là khoảng cách giữa 2 điểm mà hàm ins! trả về (tương đương dxf 10 thì phải) :D

- Khoảng cách 0.8 (BV thớt) là khoảng cách giữa 2 điểm insert của 2 text căn lề khác nhau (1 R & 1 L) (tương đương trans 1dxf 10 và 1dxf 11 _UCS không phải W)

Tháng 10 23, 2015

- Không xem được bản vẽ (có lẻ là do lỗi forum => có thể up lên một trang khác)

Tháng 10 22, 2015

@Bác Bình:

vla-invoke ... trả về có dạng (x1 y1z1 x2 y2 z2 ... xn yn zn) chứa ạh !

nên: trong code đầu (mình sửa lại từ code cũ) mình phân ra trường hợp có > 1 điểm giao thì chạy vòng lặp

>>> thấy việc phân ra trường hợp có 1 giao & >1 giao là "thừa" nên mình sửa lại code thứ 2.

@Bác tien2005:

Mình chỉ code theo yêu cầu chủ thớt như việc bóc củ khoai nóng thôi nên mới vậy :D :D :D

Tháng 10 22, 2015

Fix trường hợp có nhiều điểm thỏa mãn:

(defun c:TIMY ( / lst_va old pl x xl int_pt len)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone)) 
				(if
					(> (setq len (length int_pt)) 3)
						(repeat (/ len 3)
							(princ (strcat "\     Y = " (rtos (cadr int_pt) 2 3)))
							(setq int_pt (cdddr int_pt))
						)	  ;repeat
					(princ (strcat "\ Y = " (rtos (cadr int_pt) 2 3)))
				)	  ;if trong
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				)	;if ngoai
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)

Và tám :D :D :D

Lisp trên làm việc theo phương thức:

1, Chọn LWpolyline cho đến lúc được thì

2, Vẽ Xline theo phương đứng (Ver...)

3, Xác định giao giữa PL và XL vừa vẽ ra,

Nếu có, nếu list điểm giao do hàm vlax-invoke ...trả về có length >3 thì >>> vòng lặp: in phần tử thứ 2, cắt 3 phần tử đầu list...

nếu không (tức length = 3) thì in phần tử thứ 2;

Nếu không giao, in dòng thông báo ...

Các hàm vl đều là kết quả mà mình mót được của các bác trên diễn đàn nên mình không dám lải nhải nhiều thêm :D :D :D

Hoặc là:

(defun c:TIMY ( / lst_va old pl x xl int_pt len)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (not (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone))) 
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				(while int_pt
					(princ (strcat "\     Y = " (rtos (cadr int_pt) 2 3)))
					(setq int_pt (cdddr int_pt))
				)	  ;while
			)	  
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)

Tháng 10 20, 2015

Lâu không được code nên ngứa ngáy viết đại :D

Bạn nên sửa TUT lại cho đúng quy định kẻo bị xóa :D :D :D

(defun c:TIMY ( / lst_va old pl x xl int_pt)
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon PL! ")
(while (null pl) (prompt "\nChon PL! ") (setq pl (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
(setq pl (vlax-ename->vla-object (ssname pl 0)))
(while (setq x (getreal "\nNhap X: "))
		(progn
			(command ".xline" "v" (list x 0) "")
			(setq xl (vlax-ename->vla-object (entlast)))
			(if (setq int_pt (vlax-invoke pl 'intersectwith xl acExtendNone)) (princ (strcat "\ Y = " (rtos (cadr int_pt) 2 3)))
				(princ (strcat "*** \Khong co diem nao co gia tri X= " (rtos x 2 3) " thuoc PL da chon ! ***"))
				)	;if
			(vla-erase xl)
		)
)
(mapcar 'setvar lst_va old)
(princ)
)

Tháng 10 17, 2015

@bác Bình: Cái tật cận thị là xuất phát từ BV mẫu của chủ thớt mừ :D :D :D

Tháng 10 16, 2015

Rảnh nên mò mẫn lại tí, quên cả rồi :D

(defun c:DONG ()
(vl-load-com)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
	  tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
	  tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(foreach c coc
	(setq trai (vlax-invoke (vlax-ename->vla-object c) 'intersectwith tlt acExtendThisEntity)
		  phai (vlax-invoke (vlax-ename->vla-object c) 'intersectwith tlp acExtendThisEntity))
	(command "_.insert" "cocmoc" trai 25.4 "" "")
	(command "_.insert" "cocmoc" phai 25.4 "" "")
)
(mapcar 'setvar lst_va old)
(princ)
)

- Để block được chèn đúng vị trí, bạn cần:

Chỉnh sửa điểm chèn cái block của bạn đúng tâm đường tròn (đã có bài hướng dẫn cụ thể trên diễn đàn)

..... :D :D :D

Tháng 10 6, 2015

Chắc là muốn nhìn địa hình một cách trực quan để chọn tuyến đây mà :D

- File gốc làm BD để chạy Nova ... giữ nguyên

- File muốn 3do thì chỉ cần tạo block >>> thay đổi scale Z rồi 3DO là được (không cần phải explode)

p/s: Bạn phải luyện đọc bình đồ 2d thôi, đừng lạm dụng võ công quá :D :D :D

p/s2: Mình thử với cad2014 thì X block rất nhanh, chỉ là cho ra 1 đống line chứ ko phải là Pline :D

Đăng nhập

hiepttr

Số lượng nội dung

Đã tham gia

Lần ghé thăm cuối

Ngày trúng

Loại nội dung

Hồ sơ

Diễn đàn

Bài đăng được đăng bởi hiepttr

Xuất Tọa Độ Và Khoảng Cách Cộng Dồn Pline Ra File Excel

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Xin Lisp Về Layer

Thống Kê Text Theo Cặp

Xoay Đoạn Thẳng

Nhờ Sửa Lisp Replace Text Nhanh

Nhờ Sửa Lisp Replace Text Nhanh

Nhờ Sửa Lisp Replace Text Nhanh

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Nhờ Ghép Lisp Đổi Màu Text Khi Sửa

Nhờ Chỉnh Sửa Lisp Nối Text Cao Độ

Nhờ Giúp Đỡ Viết Lisp

Nội Suy Cao Độ Y Từ Cao Độ X Và Đồ Thị Bằng Pline, Arc

Nội Suy Cao Độ Y Từ Cao Độ X Và Đồ Thị Bằng Pline, Arc

Nội Suy Cao Độ Y Từ Cao Độ X Và Đồ Thị Bằng Pline, Arc

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ

Scan Theo Phương Z

Diễn đàn

Download

Đào tạo CADViet

Browse