thanhduan2407

Mình làm như bạn. Tắt đi bật lại không sao cả. Bạn cài lại Cad xem sao!

Mình Test rất OK trên bản vẽ bạn gửi. Còn bạn thao tác thế nào là do bạn. Mình giúp ko mất phí chỉ đến thế. Gửi phí 2 triệu mình giúp đến cuối. Ko thì Cancel. Ko ai miễn phí đâu. Mình viết bằng tâm. Nhưng vì bạn non quá. Mất tgian thêm thì mất phí. "Mọi sự ngu dốt đều trả giá bằng tiền mặt" như lời thầy giáo mình bảo.

Bạn thử xem thế nào nhé! (defun C:00 (/ G1 G2 KC LTSDIM OBJ1 OBJXLINE PNTG1 PNTG2 SSCHON SSDIM) (vl-load-com) (defun *error* (msg) (if Olmode (setvar 'osmode Olmode) ) (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (redraw) (princ) ) (command "undo" "begin") (setq Olmode (getvar "OSMODE")) (setvar "OSMODE" 0) (setq Obj1 (Car (entsel "\nChon Dimension dau tien: "))) (if (= (cdr (assoc 0 (entget Obj1))) "DIMENSION") (progn (setq ssDim (ssget '((0 . "DIMENSION")))) (if ssDim (progn (setq LtsDim (acet-ss-to-list ssDim)) (if (member Obj1 LtsDim) (setq LtsDim (vl-remove Obj1 LtsDim)) ) (if LtsDim (progn (setq G1 (angle (cdr (assoc 13 (entget Obj1))) (cdr (assoc 14 (entget Obj1))))) (setq PntG1 (cdr (assoc 11 (entget Obj1)))) (command "Xline" PntG1 (polar PntG1 G1 1.0) "") (setq ObjXline (entlast)) (setq ssChon (ssadd)) (foreach eDim LtsDim (setq G2 (angle (cdr (assoc 13 (entget eDim))) (cdr (assoc 14 (entget eDim))))) (setq PntG2 (cdr (assoc 11 (entget eDim)))) (setq KC (distance PntG2 (vlax-curve-getClosestPointto ObjXline PntG2 T))) (if (and (not (equal KC 0.0 1e-1)) (or (equal G2 G1 1e-8) (equal G2 (+ G1 pi) 1e-8)(equal G2 (- G1 pi) 1e-8)) ) (ssadd eDim ssChon) ) ) (entdel ObjXline) ) ) ) ) ) ) (if (> (sslength ssChon) 0) (progn (Alert (strcat "C\U+00F3 t\U+1EA5t c\U+1EA3 : " (rtos (sslength ssChon) 2 0) " Dim \U+0111\U+01B0\U+1EE3c ch\U+1ECDn")) (Prompt (strcat "\nC\U+00F3 t\U+1EA5t c\U+1EA3 : " (rtos (sslength ssChon) 2 0) " Dim \U+0111\U+01B0\U+1EE3c ch\U+1ECDn\n")) (sssetfirst nil ssChon) ) (progn (Alert "Kh\U+00F4ng c\U+00F3 \U+0111\U+1ED1i t\U+01B0\U+1EE3ng n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn") (Prompt "\nKh\U+00F4ng c\U+00F3 \U+0111\U+1ED1i t\U+01B0\U+1EE3ng n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn\n") ) ) (setvar "OSMODE" Olmode) (princ) )

Bạn gửi bản vẽ qua đây mình xem. Hoặc gửi qua Email: heaven2407@gmail.com Mình thử của mình OK mà

Bạn thử xem! (defun C:00 (/ G1 G2 KC LTSDIM OBJ1 OBJXLINE PNTG1 PNTG2 SSCHON SSDIM) (vl-load-com) (defun *error* (msg) (if Olmode (setvar 'osmode Olmode) ) (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (redraw) (princ) ) (command "undo" "begin") (setq Olmode (getvar "OSMODE")) (setvar "OSMODE" 0) (setq Obj1 (Car (entsel "\nChon Dimension dau tien: "))) (if (= (cdr (assoc 0 (entget Obj1))) "DIMENSION") (progn (setq ssDim (ssget '((0 . "DIMENSION")))) (if ssDim (progn (setq LtsDim (acet-ss-to-list ssDim)) (if (member Obj1 LtsDim) (vl-remove Obj1 LtsDim) ) (if LtsDim (progn (setq G1 (angle (cdr (assoc 13 (entget Obj1))) (cdr (assoc 14 (entget Obj1))))) (setq PntG1 (cdr (assoc 11 (entget Obj1)))) (command "Xline" PntG1 (polar PntG1 G1 1.0) "") (setq ObjXline (entlast)) (setq ssChon (ssadd)) (foreach eDim LtsDim (setq G2 (angle (cdr (assoc 13 (entget eDim))) (cdr (assoc 14 (entget eDim))))) (setq PntG2 (cdr (assoc 11 (entget eDim)))) (setq Kc (distance PntG2 (vlax-curve-getClosestPointto ObjXline PntG2))) (if (and (not (equal Kc 0.0 1e-8)) (or (equal G2 G1 1e-8) (equal G2 (+ G1 pi) 1e-8))) (ssadd eDim ssChon) ) ) (entdel ObjXline) ) ) ) ) ) ) (if ssChon (sssetfirst nil ssChon) ) (setvar "OSMODE" Olmode) (princ) )

Không biết như này phù hợp với bạn chưa? (defun C:00 (/ G1 G2 KC LTSDIM OBJ1 OBJXLINE PNTG1 PNTG2 SSCHON SSDIM) (vl-load-com) (defun *error* (msg) (if Olmode (setvar 'osmode Olmode) ) (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (redraw) (princ) ) (command "undo" "begin") (setq Olmode (getvar "OSMODE")) (setvar "OSMODE" 0) (setq Obj1 (Car (entsel "\nChon Dimension dau tien: "))) (if (= (cdr (assoc 0 (entget Obj1))) "DIMENSION") (progn (setq ssDim (ssget '((0 . "DIMENSION")))) (if ssDim (progn (setq LtsDim (acet-ss-to-list ssDim)) (if (member Obj1 LtsDim) (vl-remove Obj1 LtsDim) ) (if LtsDim (progn (setq G1 (angle (cdr (assoc 13 (entget Obj1))) (cdr (assoc 14 (entget Obj1))))) (setq PntG1 (cdr (assoc 11 (entget Obj1)))) (command "Xline" PntG1 (polar PntG1 G1 1.0) "") (setq ObjXline (entlast)) (setq ssChon (ssadd)) (foreach eDim LtsDim (setq G2 (angle (cdr (assoc 13 (entget eDim))) (cdr (assoc 14 (entget eDim))))) (setq PntG2 (cdr (assoc 11 (entget eDim)))) (setq Kc (distance PntG2 (vlax-curve-getClosestPointto ObjXline PntG2))) (if (and (equal Kc 0.0 1e-8) (or (equal G2 G1 1e-8) (equal G2 (+ G1 pi) 1e-8))) (ssadd eDim ssChon) ) ) (entdel ObjXline) ) ) ) ) ) ) (if ssChon (sssetfirst nil ssChon) ) (setvar "OSMODE" Olmode) (princ) )

Liệu có cách nào lọc các đối tượng dạng điểm nhanh nhất có thể không? Đệ qui thì rất lâu nếu số lượng nhiều. Chắc theo cách của @ketxu thôi

Thế thì cháu gửi bác nhé! Hii Lệnh sử dụng: CVS Link download: https://bit.ly/2Pn3bFk

Mình dùng lisp của bác @Doan Van Ha hoặc Tool của @ketxu. Mình không phải tác giả nên chưa dc phép Share.

Code cho bạn xíu! (defun C:TC1 (/ COLOR NDUNG SSTEXT TEXTN X) (setvar "Cmdecho" 0) (setq TextN (car (entsel "\nCh\U+1ECDn Text ngu\U+1ED3n: "))) (if (and TextN (or (= (cdr (assoc 0 (entget TextN))) "TEXT") (= (cdr (assoc 0 (entget TextN))) "MTEXT") ) ) (progn (setq Color (vla-get-color (vlax-ename->vla-object TextN))) (setq NDung (cdr (assoc 1 (entget TextN)))) (vla-put-color (vlax-ename->vla-object TextN) 1) (prompt "\nQu\U+00E9t ch\U+1ECDn Text c\U+1EA7n thay \U+0111\U+1ED5i n\U+1ED9i dung gi\U+1ED1ng Text ngu\U+1ED3n: " ) (setq ssText (ssget '((0 . "*TEXT")))) (if ssText (progn (mapcar '(lambda (x) (entmod (subst (cons 1 NDung) (assoc 1 (entget x)) (entget x)))) (acet-ss-to-list ssText) ) (vla-put-color (vlax-ename->vla-object TextN) Color) (Prompt "\nN\U+1ED9i dung \U+0111\U+00E3 \U+0111\U+01B0\U+1EE3c thay \U+0111\U+1ED5i " ) ) ) ) (progn (Prompt "\nB\U+1EA1n ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng kh\U+00F4ng ph\U+1EA3i Text!" ) (Alert "B\U+1EA1n ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng kh\U+00F4ng ph\U+1EA3i Text!" ) ) ) (princ) )

Tâm huyết và chịu khó quá. Chúc em năm mới gặt hái nhiều thành công, cống hiến cho diễn đàn ngày càng phát triển mạnh và bền vững. Chúc bác @Doan Van Ha sức khoẻ dồi dào và chúc toàn thể anh em gặp nhiều may mắn, thành công và hạnh phúc.

Bạn đã mở bản vẽ "KhongBietToaDo.dwg" chưa nhỉ? Còn bản VN2000 kia thì cho nó lên google earth thì đúng vị trí rồi.

Chỉ còn cách là tìm các điểm song trùng để kéo về thôi. Bản vẽ bị MOVE đi rồi. Rất may là nó không xoay. Tuy nhiên cũng chưa thể khẳng định nó là VN2000 vì chưa có cơ sở (Có thể là HN72)

(defun C:00 (/ I LTSDONG LTSTEXT SSTEXT TDO) ;;;;;;;XUAT TOA DO TEXT (vl-load-com) (setvar "CMDECHO" 0) (setq ssText (ssget (list (cons 0 "TEXT")))) (if ssText (progn (setq LtsText (acet-ss-to-list ssText)) (setq LtsDong nil) (setq i 1) (foreach eT LtsText (setq Tdo (TD:Text-Base eT)) (setq LtsDong (append LtsDong (list (list (rtos i 2 0) (rtos (cadr Tdo) 2 3) (rtos (car Tdo) 2 3) (rtos (caddr Tdo) 2 3) ) ) ) ) (setq i (1+ i)) ) (if (> (length LtsDong) 0) (progn (if (vlax-get-or-create-object "Excel.Application") (WriteToExcel LtsDong) (WriteToCSV LtsDong) ) ) ) ) ) (princ) ) (defun TD:Text-Base (ent / MA71 MA72 X11 Ma10 Ma11) (setq Ma10 (cdr (assoc 10 (entget ent)))) (setq Ma11 (cdr (assoc 11 (entget ent)))) (setq X11 (car Ma11)) (setq Ma71 (cdr (assoc 71 (entget ent)))) (setq Ma72 (cdr (assoc 72 (entget ent)))) (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0)) (and (= Ma71 0) (= Ma72 3)) (and (= Ma71 0) (= Ma72 5)) ) Ma10 Ma11 ) ) (defun WriteToExcel (lst_data / col row x xlApp xlCells) (setq xlApp (vlax-get-or-create-object "Excel.Application") xlCells (vlax-get-property (vlax-get-property (vlax-get-property (vlax-invoke-method (vlax-get-property xlApp "Workbooks") "Add" ) "Sheets" ) "Item" 1 ) "Cells" ) ) (setq row 1) (foreach pt lst_data (setq col 1) (foreach coor pt (vlax-put-property xlCells 'Item row col coor) (setq col (1+ col)) ) (setq row (1+ row)) ) (vla-put-visible xlApp :vlax-true) (mapcar (function (lambda (x) (vl-catch-all-apply (function (lambda () (if x (vlax-release-object x) ) ) ) ) ) ) (list xlCells xlApp) ) (gc) (gc) ) (defun WriteToCSV (lst_data / fl) (if (setq fl (getfiled "Output File" "" "csv" 1)) (if (setq fl (open fl "w")) (progn (foreach pt lst_data (write-line (LM:lst->str pt ",") fl ) ) (close fl) ) ) ) )

Dùng Civil hoặc MicroStation để đưa sang Cad.