Hề hề hề,
Chưa hiểu hết yêu cầu của bạn nên đoán mò và làm thử cái ni, không biết có đúng ý bạn không???
Lưu ý rằng có nhẽ nó chưa hoàn toàn đáp ứ đúng ý bạn và còn hơi rườm rà. Trong quá trình bạn dim, với mỗi điểm đều có hai lần ghi kich thước, lần 1 là tọa độ x lần 2 là tọa độ y. Bạn toàn quyền lựa chọn các vị trí đặt dim. Nếu thấy dim nào không cần...

Hề hề hề,
Chưa hiểu hết yêu cầu của bạn nên đoán mò và làm thử cái ni, không biết có đúng ý bạn không???
Lưu ý rằng có nhẽ nó chưa hoàn toàn đáp ứ đúng ý bạn và còn hơi rườm rà. Trong quá trình bạn dim, với mỗi điểm đều có hai lần ghi kich thước, lần 1 là tọa độ x lần 2 là tọa độ y. Bạn toàn quyền lựa chọn các vị trí đặt dim. Nếu thấy dim nào không cần ghi thì bạn chỉ việc bỏ qua nó bằng cách nhấn enter khi nó yêu cầu nhập điểm đặt dim. Việc ghi này mình mới chỉ làm cho các line và lwpolyline. với các circle hay các arc, elip bạn phải có đường line xác định tâm và dựa vào đó mà ghi cho phù hợp.
Hy vọng bạn chưa hài lòng.


Chúc bạn không buồn.

sau 1 hồi mày mò nhoc đã mò ra 1 cách tào lao hột dưa đưa thêm điều kiện cho bạn chọn thích tắt hay mở chế độ bắt điểm, nếu chọn tắt sau khi xong lệnh chế độ bắt điểm mà bạn set lúc đâu sẽ trở lại với bạn ^^, nếu bạn chọn mở xem như ko có gì thay đổi, lúc đầu bạn chọn thế nào thì...

sau 1 hồi mày mò nhoc đã mò ra 1 cách tào lao hột dưa đưa thêm điều kiện cho bạn chọn thích tắt hay mở chế độ bắt điểm, nếu chọn tắt sau khi xong lệnh chế độ bắt điểm mà bạn set lúc đâu sẽ trở lại với bạn ^^, nếu bạn chọn mở xem như ko có gì thay đổi, lúc đầu bạn chọn thế nào thì nó vẫn thế rứa

(defun c:dimor (/ ssl plst a b c)
(vl-load-com)
(setq b (getvar "osmode"))
(setq c (getint "\nTat hay bat bat diem 1 tat 2 mo: "))
(if (= c 1)
(setq a (setvar "osmode" 0)) (setq b (getvar "osmode")))
(command "undo" "be")
(command "ucs" "n" "o" (getpoint))
(setq ssl (acet-ss-to-list (ssget (list (cons 0 "*line")))))
(foreach pl ssl
(if (= (cdr (assoc 0 (entget pl))) "LWPOLYLINE")
(setq plst (acet-geom-vertex-list pl))
(setq plst (list (trans (cdr (assoc 10 (entget pl))) 0 1) (trans (cdr (assoc 11 (entget pl))) 0 1)))
)
(foreach ver plst
(command "dimordinate" ver "x" (getpoint ver) "")
(command "dimordinate" ver "y" (getpoint ver) "")
)
)
(command "undo" "e")
(setvar "osmode"
(princ)
)

ah ra là anh Tue quy định layer ^^, nhoc đọc chưa hỉu kaka ^^, thui sữa lại xíu cho bạn í lun hen chơi lun layer hiện hành cho tiện, nhoc thêm vô arc, circle cho đủ bộ use tối đa hàm con anh Tue viết lun hen
;; free lisp from cadviet.com
;;; this lisp was downloaded from...

ah ra là anh Tue quy định layer ^^, nhoc đọc chưa hỉu kaka ^^, thui sữa lại xíu cho bạn í lun hen chơi lun layer hiện hành cho tiện, nhoc thêm vô arc, circle cho đủ bộ use tối đa hàm con anh Tue viết lun hen
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=68893&pid=226493&st=0&#entry226493
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=68893&pid=226458&st=0&#entry226458
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun Tue-ent-Lpoint(e / i Lpoint);Tue-dxf
(if (wcmatch (Tue-dxf 0 e) "*POLYLINE")
(progn
(if (= (type e) 'VLA-OBJECT) (setq e (vlax-vla-object->ename e)))
(setq i -1)
(Repeat (if (wcmatch (Tue-dxf 0 e) "*POLYLINE") (fix (1+ (vlax-curve-getEndParam e))) 2)
(setq Lpoint (append Lpoint (list (vlax-curve-getPointatParam e (setq i (1+ i))))))
)
)
)
(if (wcmatch (Tue-dxf 0 e) "LINE")
(setq Lpoint (append Lpoint (list (Tue-dxf 10 e) (Tue-dxf 11 e))))
)
(if (wcmatch (Tue-dxf 0 e) "ARC,CIRCLE")
(setq Lpoint (append Lpoint (list (Tue-dxf 10 e) )))
)
Lpoint
)
(defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)

(mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
(setq L (sslength ssg))
(Repeat L
(setq ename (ssname ssg (setq L (1- L))))
(setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
)
)
(defun c:dorr (/ oldos ssd)
(vl-load-com)
(setq kc (getreal "\nNhap khoang cach mong mun <6.0>: "))
(if (= kc nil) (setq kc 6.0))
(setq oldos (getvar "osmode"))
(command "undo" "be")
(setq ssd (Tue-ss-list (list (ssget '((0 . "*LINE,CIRCLE,ARC"))))))
(command "ucs" "m" (setq goc (getpoint "\n Chon goc toa do tuong doi :")))

(setvar "osmode" 0)
(foreach x ssd
(foreach z (Tue-ent-Lpoint x)
(setq z (trans z 0 1))
(command "DIMORDINATE" z "y" (list (+ (car z) kc) (cadr z) (caddr z)) )
(command "DIMORDINATE" z "x" (list (car z) (+ (cadr z) kc) (caddr z)))

)
)
(setvar "osmode" oldos)
(command "ucs" "p")
(command "undo" "e")
)

Hề hề hề,
Gửi lại lisp đã chỉnh chút chút ở các điều kiện cho đúng. Lúc trước mình để hàm (= (.....) "*POLYLINE") có thể CAD của nhóc không hiểu nên đổi lại thành hàm điều kiện or cho nó dài dòng văn tự. Ngoài ra sử dụng the6mm hàm trans để chuyển tâm các cung tròn về hệ tọa độ lựa chọn.


Hy vọng đúng ý nhóc, đã test trên bản vẽ nhóc gửi thì...

Hề hề hề,
Gửi lại lisp đã chỉnh chút chút ở các điều kiện cho đúng. Lúc trước mình để hàm (= (.....) "*POLYLINE") có thể CAD của nhóc không hiểu nên đổi lại thành hàm điều kiện or cho nó dài dòng văn tự. Ngoài ra sử dụng the6mm hàm trans để chuyển tâm các cung tròn về hệ tọa độ lựa chọn.


Hy vọng đúng ý nhóc, đã test trên bản vẽ nhóc gửi thì thấy không thể đẹp hơn.
Hề hề hề.

Năm mới chúc các Bác nhiều sức khỏe và Diễn đàn ngày một phát triển hơn!
Nhờ các Bác xem giúp đoạn code sau, mục đích của đoạn code là tạo 1 attribute nhưng vẫn chưa chạy được?
;;;;;;;;MAIN;;;;;;;;;
(defun C:1att (/ p0 G00 G90 LL)
(setq G00 0.0
G90 (* pi 0.5))
(setq p0 (getpoint "\nChon dien chen Attribute: "))
(setq LL '("111" "222" "333"))
...

Năm mới chúc các Bác nhiều sức khỏe và Diễn đàn ngày một phát triển hơn!
Nhờ các Bác xem giúp đoạn code sau, mục đích của đoạn code là tạo 1 attribute nhưng vẫn chưa chạy được?
;;;;;;;;MAIN;;;;;;;;;
(defun C:1att (/ p0 G00 G90 LL)
(setq G00 0.0
G90 (* pi 0.5))
(setq p0 (getpoint "\nChon dien chen Attribute: "))
(setq LL '("111" "222" "333"))

(Make_att LL "standard" "0" p0 3.0 G00 1)

(princ)
)
(Princ "\nStart command with <1att>")
;;;;; Ham con tao att
(defun Make_att (LIST_ATT STYLE LAYER POINT HEIGHT ANG COLOR); Ang: Radial
(entmake (list (cons 0 "ATTDEF")
(cons 100 "AcDbEntity")
(cons 7 (if STYLE STYLE (getvar "TextSTYLE")))
(cons 8 (if LAYER LAYER (getvar "CLAYER")))
(cons 100 "AcDbText")
(cons 100 "AcDbAttributeDefinition")
(cons 10 POINT)
(cons 11 POINT)
(cons 40 HEIGHT)
(if ANG (cons 50 ANG))
(cons 62 (if COLOR COLOR 256))
(cons 1 (nth 0 LIST_ATT)) ; Default value (string)
(cons 2 (nth 1 LIST_ATT)) ; Tag (string and can not contain spaces)
(cons 3 (nth 2 LIST_ATT)) ; Prompt (string)
);end list
);entmake
);end defun

Hề hề hề,
Thú thực là không khoái lắm với cái lisp này, song vì bạn thích dùng nó nên thôi đành ngậm ...... ớt sửa chút chút để bạn xài thử. Kết cấu lisp kiểu này hơi ...... lẩm cẩm, tuy nó vẫn chạy được xong khá mất thời gian.
Của bạn đây, xài thử và cho ý kiến.

Bạn nên lưu ý vài điều như sau:
1/- Trước khi chạy lisp nên dùng overkill để tiêu diệt...

Hề hề hề,
Thú thực là không khoái lắm với cái lisp này, song vì bạn thích dùng nó nên thôi đành ngậm ...... ớt sửa chút chút để bạn xài thử. Kết cấu lisp kiểu này hơi ...... lẩm cẩm, tuy nó vẫn chạy được xong khá mất thời gian.
Của bạn đây, xài thử và cho ý kiến.

Bạn nên lưu ý vài điều như sau:
1/- Trước khi chạy lisp nên dùng overkill để tiêu diệt bớt kẻ thù của lisp.
2/- Các thuộc tính của các line mặt đất, text, line ghi chú .... phải đảm bảo giống như trên bản vẽ bạn đã gửi. Chỉ cần các thuộc tinh này thay đổi thì lisp sẽ có thể cho bạn đi tàu bay giấy ngay.
3/- Khi quét chọn các đối tượng cần di chuyển, bạn nên quét chọn từng vùng nhỏ tránh lấy thêm vài nghìn đối tượng không mong muốn. Số lượng đối tượng này càng to thì lisp chạy càng lâu và không ngoại trừ nó tẩu hỏa nhập loanh quanh thì bạn mệt người.
4/- Lisp yêu cầu bạn chọn cả block, cả các cụm text-line cần di chuyển trong một lần chọn duy nhất nên bạn cứ nhẩn nha mà chọn cho tới khi đủ khoái. Miễn rằng đừng chọn nhầm mà tự làm khổ mình. Trong trường hợp nhỡ nhầm, hãy cứ yên tâm chạy lisp rồi undo một phát nó sẽ trả về nguyên trạng trước khi chạy lisp. Nếu không muốn mất thời gian ngồi đợi có thể nhấn ESC rồi nhập lệnh undo, end. Sau đó undo một phát là nó quên hết những gì đã làm và trả cho bạn bản vẽ u như kỵ.
5/- Kết quả của lisp là chuyển các block trên bản vẽ mà bạn cần chuyển về nằm trên đường line mặt đất với tọa độ x không thay đổi. các cụm text-line sẽ chuyển tới vị trí cách đường line mặt đất một khoảng mà bạn được yêu cầu nhập vô trước đó và nằm cùng toạc độ x vốn có của điểm giữa line trong mỗi cụm. Đồng thời nó căn chỉnh cho các text nằm ngay ngắn với line theo một trật tự xác định. Nếu muốn các cụm này nằm trên , dưới hay chình ình giữa đường line mặt đất thì bạn nhập giá trị khoảng cách này là các số lớn hơn, nhỏ hơn hay bằng 0.

Chúc bạn một năm sắp mới vui vẻ....
Hề hề hề

Sửa nhanh cho bạn đây.
;; By CAB 12.30.08
(defun c:BlockRename (/ prefix siffix n usercmd)
;; ignore xref, xref dependent and anonymous
(defun GetBlkNames (/ data result)
(while (setq data (tblnext "block" (null data)))
(if (zerop (logand 21 (cdr (assoc 70 data))))
(setq result (cons (cdr (assoc 2 data)) result))
)
)
(acad_strlsort result)
)

(if (and
(setq prefix...

Sửa nhanh cho bạn đây.
;; By CAB 12.30.08
(defun c:BlockRename (/ prefix siffix n usercmd)
;; ignore xref, xref dependent and anonymous
(defun GetBlkNames (/ data result)
(while (setq data (tblnext "block" (null data)))
(if (zerop (logand 21 (cdr (assoc 70 data))))
(setq result (cons (cdr (assoc 2 data)) result))
)
)
(acad_strlsort result)
)

(if (and
(setq prefix (getstring t "\nEnter Block prefix: "))
(setq suffix (getstring t "\nEnter Block suffix: "))
)
(progn
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "_undo" "_begin")
;; Walk through the collection
(foreach n (GetBlkNames)
(if (vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(command "_.-rename" "_b" n (strcat prefix n suffix))
(princ (strcat "\n" n " --> " prefix n suffix))
)
)
)
(prompt (strcat "\nError for block name: " prefix n suffix))
)
)
(command "_undo" "_end")
(setvar "CMDECHO" usercmd)
)
)
(princ)
)

Lisp của bạn đây. Lệnh ct nhé. Hy vọng đúng ý bạn.
http://www.cadviet.c...change_text.lsp

(defun C:ct()
(setq taphop(ssget))
(setq soluong (sslength taphop))
(setq index 0)
(setq i 0)
(while (< index soluong)
(setq TEXT (entget (ssname taphop index)))
(setq KIEU(cdr(assoc 0 TEXT)))
(if (= KIEU "TEXT")
(progn
(setq i(1+ i))
(if (= (+ (cdr(assoc 72 TEXT))...

Lisp của bạn đây. Lệnh ct nhé. Hy vọng đúng ý bạn.
http://www.cadviet.c...change_text.lsp

(defun C:ct()
(setq taphop(ssget))
(setq soluong (sslength taphop))
(setq index 0)
(setq i 0)
(while (< index soluong)
(setq TEXT (entget (ssname taphop index)))
(setq KIEU(cdr(assoc 0 TEXT)))
(if (= KIEU "TEXT")
(progn
(setq i(1+ i))
(if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
(setq InsertPoint(cdr(assoc 10 TEXT)))
(setq InsertPoint(cdr(assoc 11 TEXT)))
)
(entmod (subst (cons 1 (rtos (caddr InsertPoint) 2 2)) (assoc 1 TEXT) TEXT))
)
)
(setq index (+ index 1))
)
(alert (strcat (rtos i 2 0) " objects changed"))
(princ)
)

Lisp mới sẽ thay đổi cao độ từ dương thành âm, âm thành dương. TEXT hiển thị sẽ tuỳ theo cao độ âm hay dương.
http://www.cadviet.c...e_text_rev1.lsp

(defun C:ct()
(command "OSMODE" 0)
(setq os(getvar "osmode"))
(setq taphop(ssget '(( 0 . "TEXT"))))
(setq soluong (sslength taphop))
(setq index 0)
(command "UNDO" "BE")
(while (<...

Lisp mới sẽ thay đổi cao độ từ dương thành âm, âm thành dương. TEXT hiển thị sẽ tuỳ theo cao độ âm hay dương.
http://www.cadviet.c...e_text_rev1.lsp

(defun C:ct()
(command "OSMODE" 0)
(setq os(getvar "osmode"))
(setq taphop(ssget '(( 0 . "TEXT"))))
(setq soluong (sslength taphop))
(setq index 0)
(command "UNDO" "BE")
(while (< index soluong)
(setq TEXT (entget (ssname taphop index)))
(if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
(setq InsertPoint(cdr(assoc 10 TEXT)))
(setq InsertPoint(cdr(assoc 11 TEXT)))
)
(if (> (caddr InsertPoint) 0)
(setq newstring(strcat "-" (rtos (caddr InsertPoint) 2 2)))
(setq newstring(rtos (- 0 (caddr InsertPoint)) 2 2))
)
(entmod (subst (cons 1 newstring) (assoc 1 TEXT) TEXT))
(command "move" (ssname taphop index) "" (list 0 0 (caddr InsertPoint)) (list 0 0 (- 0 (caddr InsertPoint))))
(setq index (+ index 1))
)
(command "OSMODE" os)
(command "UNDO" "END")
(princ)
)

PS: Bạn làm bản vẽ đo sâu đúng không? Mấy bác đo sâu hay đưa điểm lên bản vẽ như này.

Lisp trên tuy chạy tốt nhưng vẫn còn vấn đề cần phải xử lý đó là: Nếu tập chọn có cả text biểu thị độ cao(dạng số) và text ghi chú (dạng chữ) thì các text dạng chữ sẽ bị thay đổi tuỳ theo positionZ của text này. Nếu người sử dụng vô tình chọn đối tượng có cả text ghi chú thì các text này sẽ bị mất và thay vào đó là text với nội dung là “0.00” (trong trường hợp Z=0). Lisp...

Lisp trên tuy chạy tốt nhưng vẫn còn vấn đề cần phải xử lý đó là: Nếu tập chọn có cả text biểu thị độ cao(dạng số) và text ghi chú (dạng chữ) thì các text dạng chữ sẽ bị thay đổi tuỳ theo positionZ của text này. Nếu người sử dụng vô tình chọn đối tượng có cả text ghi chú thì các text này sẽ bị mất và thay vào đó là text với nội dung là “0.00” (trong trường hợp Z=0). Lisp dưới đây đã khắc phục được vấn đề đó.

(defun C:ct()
(setq os(getvar "osmode"))
(command "OSMODE" 0)
(setq taphop(ssget '(( 0 . "TEXT"))))
(setq soluong (sslength taphop))
(setq index 0)
(command "UNDO" "BE")
(while (< index soluong)
(setq TEXT (entget (ssname taphop index)))
(if (= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT))))
(progn
(if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
(setq InsertPoint(cdr(assoc 10 TEXT)))
(setq InsertPoint(cdr(assoc 11 TEXT)))
)
(if (> (caddr InsertPoint) 0)
(setq newstring(strcat "-" (rtos (caddr InsertPoint) 2 2)))
(setq newstring(rtos (- 0 (caddr InsertPoint)) 2 2))
)
(entmod (subst (cons 1 newstring) (assoc 1 TEXT) TEXT))
(command "move" (ssname taphop index) "" (list 0 0 (caddr InsertPoint)) (list 0 0 (- 0 (caddr InsertPoint))))
)
)
(setq index (+ index 1))
)
(command "OSMODE" os)
(command "UNDO" "END")
(princ)
)

Nhờ các anh sửa giúp em với yêu cầu sau:
gõ lệnh => chọn Pline => xong

bỏ bớt giúp em những dòng hỏi màu đỏ dưới đây:
Command: Test
Select objects: 1 found
Select objects:
Specify Circle Radius :0.1 (ĐỂ MẶC ĐỊNH 0.1, KHÔNG HỎI)
Enter Layer name :0 (TỰ TẠO LAYER CÓ MẦU SỐ 4, TÊN LAYER LÀ ĐIỂM VÀ CUNG TRÒN CÓ MÀU ĐÓ. KHÔNG HỎI)
cảm ơn các anh!

>>

Nhờ các anh sửa giúp em với yêu cầu sau:
gõ lệnh => chọn Pline => xong

bỏ bớt giúp em những dòng hỏi màu đỏ dưới đây:
Command: Test
Select objects: 1 found
Select objects:
Specify Circle Radius :0.1 (ĐỂ MẶC ĐỊNH 0.1, KHÔNG HỎI)
Enter Layer name :0 (TỰ TẠO LAYER CÓ MẦU SỐ 4, TÊN LAYER LÀ ĐIỂM VÀ CUNG TRÒN CÓ MÀU ĐÓ. KHÔNG HỎI)
cảm ơn các anh!


(defun c:Test (/ ss di la) ;;; Tharwat 14. Nov. 2012 ;;;
(if (and (setq ss (ssget '((0 . "*POLYLINE"))))
(setq di (getdist "\n Specify Circle Radius :"))
(not (eq (setq la (getstring t "\n Enter Layer name :")) ""))
(tblsearch "LAYER" la) ) ((lambda (x / e)
(while (setq e (ssname ss (setq x (1+ x))))
(foreach dxf (entget e) (if (eq (car dxf) 10)
(entmakex (list '(0 . "CIRCLE") dxf (cons 40 di) (cons 8 la)))
) ) ) ) -1 ) (princ) ) (princ))

-SAu 1 hồi mò mẫn cuối cùng nhoc cũng mò đc theo đúng yêu cầu của bạn ni
Nhưng có 1 chỗ oái ăm nhoc chưa hỉu là tự tạo layer màu số 4, tên layer la diem ko có gì phải bàn nhưng hình tròn vẽ ra lại là màu số 1 ??? >>nhoc hỉu sai chăng

>>

-SAu 1 hồi mò mẫn cuối cùng nhoc cũng mò đc theo đúng yêu cầu của bạn ni
Nhưng có 1 chỗ oái ăm nhoc chưa hỉu là tự tạo layer màu số 4, tên layer la diem ko có gì phải bàn nhưng hình tròn vẽ ra lại là màu số 1 ??? >>nhoc hỉu sai chăng
Trước mắt làm theo những gì nhoc hỉu

;Edit by nhoclangbat ^^
(defun c:ttt (/ ss)
(command "-layer" "m" "diem" "C" 4 "diem" "")
(if (and (setq ss (ssget '((0 . "*POLYLINE"))))
)
((lambda (x / e)
(while (setq e (ssname ss (setq x (1+ x))))
(foreach dxf (entget e) (if (eq (car dxf) 10)
(entmakex (list '(0 . "CIRCLE") '(62 . 1) dxf (cons 40 0.1) (cons 8 "diem")))
) ) ) ) -1 ) (princ) )
(princ))


Ps: thật ra mí hàm này anh Ket chưa dạy tới nhưng may hồi đó đc anh Bình hướng dẫn sữa cái lsp vn2000 làm nhìu nên cũng nắm đc sơ sơ mí cái mã dfx rùi hàm entmake tạo đối tượng, if , ..... chứ nhoc cũng chả hỉu chi rứa ^^