Đến nội dung


Hình ảnh
* * * - - 8 Bình chọn

Viết lisp theo yêu cầu [phần 2]


  • Chủ đề bị khóa Chủ đề bị khóa
3783 replies to this topic

#501 master_worse

master_worse

    biết lệnh offset

  • Advance Member
  • PipPipPip
  • 170 Bài viết
Điểm đánh giá: 87 (tàm tạm)

Đã gửi 12 December 2009 - 07:57 PM

....Yêu cầu:
Viết lệnh autolisp có tên là 1,2,3,4,… dùng để thực hiện các lệnh về ghi kích thước trong Autocad.
Ví dụ:
Command: 1
- Chuyển sang lớp KT-Dim (bảo đảm khi thực hiện dù đang ở lớp nào cũng nhảy về Layer KT-Dim)
- Thực hiện lệnh _dimlinear
- Chuyển về Layer trước đó (cái vế này thì tôi bí)
....


trừ DIMCONTINUE các dim khác mình có thể làm giúp bạn được
nhưng

....
Bây giờ đến lượt tui có lời yêu cầu “nhỏ như con thỏ” mong được gia_bach giúp đỡ đây (nhờ thật tình và đích danh).
....

đành thôi vậy :(
  • 0

Ngu dốt không đáng thẹn bằng thiếu ý chí học hỏi


Tri thức làm người ta khiêm tốn, ngu si làm người ta kiêu ngạo (Ngạn ngữ Anh)


#502 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1359 (rất tốt)

Đã gửi 12 December 2009 - 08:04 PM

trừ DIMCONTINUE các dim khác mình có thể làm giúp bạn được

Ủa DIMCONTINUE bạn vướng chổ nào à (bàn luận ngoài yêu cầu của trinhvqh). Lựa chọn Select là giải quyết được mà (mình nghỉ thế).
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#503 master_worse

master_worse

    biết lệnh offset

  • Advance Member
  • PipPipPip
  • 170 Bài viết
Điểm đánh giá: 87 (tàm tạm)

Đã gửi 12 December 2009 - 08:55 PM

Ủa DIMCONTINUE bạn vướng chổ nào à (bàn luận ngoài yêu cầu của trinhvqh). Lựa chọn Select là giải quyết được mà (mình nghỉ thế).

vấn đề ở chổ không thể điều chỉnh layer như mong muốn.
  • 0

Ngu dốt không đáng thẹn bằng thiếu ý chí học hỏi


Tri thức làm người ta khiêm tốn, ngu si làm người ta kiêu ngạo (Ngạn ngữ Anh)


#504 tvduc

tvduc

    biết vẽ line

  • Members
  • PipPip
  • 22 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 14 December 2009 - 01:08 AM

....
Mình góp ý với bạn 1 tí trong Code của bạn nhé :
-> Không nên sử dụng hàm getdist để nhập góc trong code cụ thể là :
(setq a (getdist "\n Nhap goc xoay cua coc: "))
-> Nên sử dụng hàm getangle để nhập góc -> Kết quả sẽ trả về radian : và trong hàm cos; sin thì bạn không cần phải chuyển sang Radian nữa
(setq a (getangle "\n Nhap goc xoay cua coc: "))
-> Nhập 45 sẽ trả lại kết quả 0.785398 (RAD)

1. Bác Tue_NV ơi! với hàm getangle, lúc nhập giá trị âm thì nó không đúng bác à.
2. Nhờ các bác sửa giùm tùy chọn cọc xiên hay thẳng, sao hàm (if (= xt T) chương trình không hiểu?

Cảm ơn các bác.


; Doi voi mot so ket cau nhu cau tau, tru neo. Thuong co truong hop coc xien trong khong gian,
; Lisp nay giup ve nhanh mo hinh ket cau 3D ngay tren cua so 2D cua ACAD ma khong can phai biet ve trong 3D.
; (chi ve phan coc va dam ....)
; Lenh ve CS
; Huong dan HD
(defun c:cs()
(setq oldo (getvar "osmode"))
(setvar "osmode" 33)
(command "layer" "m" "Fram" "c" 2 "" "")
(princ "\n Lisp Ve coc khong gian - ung dung lap mo hinh cho SAP tu ACAD: Tvduc")
(setq
Lu (getdist "\n Nhap chieu dai chiu uon: ")
)
;??? Giup do
(initget 1 "X T")
(setq xt (getkword "\n Coc Xien/Thang [X,T]? :"))
(if (= xt T) ;;;;;;;;;;;;;;Sao khong chuong trinh khong hieu ham nay????????????
(progn
(setq x 0 y 0)
)
(progn
(setq m (getdist "\n Nhap do xien cua coc 1/m: "))
(while (and (< m 5) (/= m 0))
(alert"Ban oi! Do xien cua coc phai la so duong, va khong duoc xien qua 1/5,lam on nhap lai nhe!")
; Tuy thuoc vao tung cong trinh cu the ma do xien cua coc co the vuot ngoai gia tri tren.
(setq m (getdist "\n Nhap lai do xien cua coc 1/m: "))
)
(while (> m 10)
(alert"Ban oi! Do xien cua coc nho hon 1/10 khong co y nghia, xem lai ket cau nhe!")
(setq m (getdist "\n Nhap lai do xien cua coc 1/m: "))
);while


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if (/= m 0)
(progn[b][size=5]
; (setq a (getangle "\n Nhap goc xoay cua coc: ")) ; khi nhap gia tri am thi cho ket qua khong dung![/size][/b]
(setq a (getdist "\n Nhap goc xoay cua coc: "))
(setq a (/ (* pi a) 180))
(while (or (< a (- 0 (/ pi 2))) (> a (/ pi 2)))
(alert"Ban oi! Góc xoay co gia tri tu -45 den +45 do^. thoi! Lam on nhap lai nhe.")
(setq a (getdist "\n Coc xoay quan truc: "))
; Tuy thuoc tung bai toan cu the.
);while
(setq aa (getdist "\n Coc xoay quan truc: "))
(while (and (/= aa 1)(/= aa 2)(/= aa 3)(/= aa 4))
(alert"Ban oi! Chieu duong truc x la truc 1, Chieu duong truc y la truc 2, Chieu am truc x la truc 3, Chieu am truc y la truc 4! Lam on nhap lai nhe.")
(setq aa (getdist "\n Coc xoay quan truc: "))
);while
(setq
a (+ (* (- aa 1) (/ pi 2)) a)
xy (/ Lu m)
x (* xy (cos a))
y (* xy (sin a))
)
)
(progn
(setq x 0 y 0)
); end Eles
);if
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(while (setq p1 (getpoint "\n Vi tri dinh coc ?"))
(if p1
(progn
(setq p2 (list (+ (car p1) x) (+ (cadr p1) y) (- 0 Lu)))
(command "_line" p1 p2 "")
)
);if
);while
(setvar "osmode" oldo)

(princ "\n Can phai chuyen tat cac cac doi tuong dam ve Layer Fram")
(print)
); defun
(defun c:hd ()
(print "Chieu duong cua goc xoay nguoc chieu voi kim dong ho")
(print "Goc toa do la dinh coc")
(print "Chieu duong truc x la truc 1")
(print "Chieu duong truc y la truc 2")
(print "Chieu am truc x la truc 3")
(print "Chieu am truc y la truc 4")
(princ)
)

  • 0

#505 tvduc

tvduc

    biết vẽ line

  • Members
  • PipPip
  • 22 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 14 December 2009 - 01:16 AM

Bạn tham khảo Lisp sau :

(defun c:svp(/ ent dz Viewport)
(if (/= (getvar "cvport") 1)
(alert "\nChi co the chay tren khong gian giay (LAYOUT).")
(progn
(while
(not
(and
(setq ent (car (entsel "\nChon Viewport : ")))
(or
(= (cdr (assoc 0 (entget ent))) "VIEWPORT")
(= (cdr (assoc 0 (entget (setq ent (cdr (assoc 330 (entget ent))))))) "VIEWPORT")
)
)
)
(princ "\nkhong phai Viewport. Chon lai : ")
)
(setq dz (getvar "dimzin"))
(setvar "dimzin" 8 )
(setq Viewport (vlax-Ename->Vla-Object ent)
sc (vla-get-CustomScale Viewport))
(alert (strcat "\nCustom Scale : " (rtos sc) " or " (strcat "1/" (rtos (/ 1 sc)))))
(setvar "dimzin" dz )
)
)
(princ) )


Hihi răng nỏ (sao không) chạy được bác!
  • 0

#506 dvqkt112

dvqkt112

    biết zoom

  • Members
  • Pip
  • 10 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 14 December 2009 - 09:49 AM

cảm ơn anh gia_bach, cái list của anh đã giúp em rất nhiều.
  • 0

#507 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 December 2009 - 09:50 AM

Hihi răng nỏ (sao không) chạy được bác!

Không chạy đuợc chỗ mô ?

Rứa hắn tỏ chi mô ?
  • 0

#508 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 December 2009 - 10:55 AM

Lisp của gia_bach tuy chưa hoàn hảo nhưng cũng đủ làm Fan “tung hô”
(Mà kỳ ghê. Lúc nào gia_bach cũng giải quyết vấn đề không rốt ráo)

Theo quan điểm cá nhân: Trước đây tôi thấy có bác Hoành (đụng độ rồi), bây giờ có thêm gia_bach là 02 cao thủ “Ô tô líp”.

Bây giờ đến lượt tui có lời yêu cầu “nhỏ như con thỏ” mong được gia_bach giúp đỡ đây (nhờ thật tình và đích danh).

Yêu cầu:
Viết lệnh autolisp có tên là 1,2,3,4,… dùng để thực hiện các lệnh về ghi kích thước trong Autocad.
Ví dụ:
Command: 1
- Chuyển sang lớp KT-Dim (bảo đảm khi thực hiện dù đang ở lớp nào cũng nhảy về Layer KT-Dim)
- Thực hiện lệnh _dimlinear
- Chuyển về Layer trước đó (cái vế này thì tôi bí)

Hy vọng gia_bach giải quyết vấn đề thuyết phục nhé.
Xin cảm ơn!
Hẹn hậu tạ nếu có dịp :(

Chào trinhvqh
Đầu tuần hơi bị bận, giờ mới hầu chuyện bác đuợc.

Trước tiên về cái chuyện nhờ đích danh :
- chắc bác đã thấy đuợc tai hại của việc nhờ đích danh 1 ai đó trong diễn đàn.
- theo nhận xét của cá nhân tui : trên CadViet có trên 10 thành viên có thể đáp ứng đuợc yêu cầu của bác. Và thực tế thì đã có 2 member lên tiếng.
Nếu bác không nhờ đích danh thì có lẽ Bác đã có đuợc LISP cách đây vài ngày. (hi : cũng đỡ cho tui phải trả lời bác )

Kế đến : "giải quyết vấn đề thuyết phục nhé""Lúc nào gia_bach cũng giải quyết vấn đề không rốt ráo)"
Có thể đã từng có nhiều vấn đề đã không đuợc giải quyết rốt ráo, nhưng tui chỉ nhắc lại 2 vấn đề gần đây nhất (cũng là đại diện cho các vấn đề khác) :
1./ Lập bảng tọa độ điểm
2./ Trim tất cả các đoạn ống đi ngang qua block hố ga

Vấn đề thứ 1 tui đã trả lời, không tiện nhắc lại ở đây. Tham khảo : http://www.cadviet.c...o...ost&p=81408
Vấn đề thứ 2 : Trim tất cả các đoạn ống đi ngang qua block hố ga
Đôi dòng về Quan điểm viết LISP của tui là :
- LISP viết ra có giảm đuợc thời gian của CadMan không ? Nếu không giảm đuợc thời gian thì không nên sử dụng (viết) LISP
- Sẽ có bao nhiêu nguời sử dụng LISP đó ? Nếu chỉ có 1 hoặc 2 nguời dùng thì hiệu quả không cao -> không nên đầu tư (viết LISP).
- Vấn đề đã đuợc nói đến (giải quyết) trên CADVIET chưa ? Nếu vấn đề chưa đuợc nói đến (giải quyết) trên CADVIET, có thể là các member không quan tâm hay chưa biết cách giải quyết (hoặc tệ hơn là không muốn share). Dù thế nào đi nữa thì tui cũng chỉ muốn chia sẽ kinh nghiệm học mót đuợc từ Cộng đồng mã nguồn mở mà LISP là 1 trong những thành viên.

Yêu cầu : Trim tất cả các đoạn ống đi ngang qua block hố ga không đáp ứng đuợc 2 tiêu chí đầu, nhưng với tiêu chí : chưa đuợc nói đến (giải quyết) trên CADVIET thì OK (yêu cầu Lập bảng tọa độ điểm cũng đáp ứng đuợc tiêu chí này).

Với tiêu chí chia sẽ kinh nghiệm viết LISP thì mức độ đáp ứng yêu cầu của bài toán sẽ không đuợc xem trọng hay "giải quyết không rốt ráo", LISP chủ yếu là thể hiện giải thuật, giới thiệu môt số hàm mới ... (và điều này chỉ hữu ích cho các "Programer").
Nhưng thực tế hiệu quả của LISP Trim tất cả các đoạn ống đi ngang qua block hố ga cũng rất cao : (1000- 2 đầu mút)/ 1000 ~ 99.99 %

...(cái này của em có tới 1000 hố ga, em muốn cắt đường cống đi qua hố ga)

Gửi bạn LISP : Chuyển sang lớp KT-Dim, Thực hiện lệnh _dimlinear, Chuyển về Layer trước đó
các lệnh khác thực hiện tương tự (thay thế tên lệnh dimlinear).
(defun c:1(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimlinear" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)

  • 2

#509 trinhvqh

trinhvqh

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 408 Bài viết
Điểm đánh giá: 222 (khá)

Đã gửi 14 December 2009 - 11:23 AM

Tôi vừa Test thử Lisp của gia_bach
Phải nói chạy rất OK
Xin cảm ơn rất nhiều!
……
Việc tôi nhờ đích danh quả thật sáng suốt (01 người cho chín còn hơn 9 người)
Chờ đợi một chút để có kết quả tốt rất thích đáng, p k?
….
Còn cái việc gia_bach biện hộ cho 02 cái Lisp trước đây thật không thuyết phục chút nào
------
À, xin cảm ơn duy782006 và master_worse
  • 0

#510 dvqkt112

dvqkt112

    biết zoom

  • Members
  • Pip
  • 10 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 14 December 2009 - 11:28 AM

Đúng là chưa hoàn hảo thật, nhưng đối với em nó cũng rất tốt rồi, không có thì Trim mỏi ca tay mất, cảm ơn anh nhiều nhé.
  • 0

#511 dvqkt112

dvqkt112

    biết zoom

  • Members
  • Pip
  • 10 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 14 December 2009 - 11:37 AM

Em làm xong rồi, nhưng vẫn thấy cái TRIMBL này thật hữu hiệu, nếu các anh có thời gian thì giúp em hoàn thiện nó nhé. List của anh Gia_bach chỉ Tr trên 1 đoạn cống trong 1 lệnh, nếu có thể làm 1 lệnh mà tr được nhiều đoạn cống khác nhau thì tuyệt biết bao.
  • 0

#512 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 December 2009 - 01:27 PM

Em làm xong rồi, nhưng vẫn thấy cái TRIMBL này thật hữu hiệu, nếu các anh có thời gian thì giúp em hoàn thiện nó nhé. List của anh Gia_bach chỉ Tr trên 1 đoạn cống trong 1 lệnh, nếu có thể làm 1 lệnh mà tr được nhiều đoạn cống khác nhau thì tuyệt biết bao.

LISP làm 1 lệnh mà trim được nhiều đoạn cống khác nhau.
Chú ý : Lisp chỉ sử lý trường hợp block hố ga giao với đường ống (Line, Arc, PLine) tại 2 điểm.
Do đó trong file của bạn, lisp không sử lý điểm ngoài cùng.
(vl-load-com)
(defun C:TRIMBLK (/ ent ipts lstblk lstpts lstptspa obj ss)
;; By : Gia Bach, Copyrightc December 2009 ;;
;; Contact : gia_bach @ www.CadViet.com ;;
(defun BlockIntersObj (Blk Obj / iPts pt_lst)
(foreach memb (vlax-invoke Blk 'Explode)
(if (eq (vla-get-ObjectName memb) "AcDbPolyline")
(setq iPts (vlax-invoke memb 'IntersectWith Obj 0)) )
(vla-delete memb)
)
(if iPts
(repeat (/ (length iPts) 3)
(setq pt_lst (cons (list (car iPts)(cadr iPts)(caddr iPts)) pt_lst)
iPts (cdddr iPts) ) ) )
(if pt_lst (reverse pt_lst))
)
;--------------- main -------------------
(command "undo" "be")
(princ "\nChon doi tuong can Trim : ")
(if (setq ss (ssget (list (cons 0 "*LINE,ARC"))))
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst_pt (TraceObject obj)
ssBlk (ssget "f" lst_pt(list (cons 0 "INSERT") (cons 8 "Hoga"))))
(foreach e (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBlk))))
(if (and (setq iPts (BlockIntersObj e obj)) (=(vl-list-length iPts)2))
(foreach pt iPts
(setq lstPtsPa (cons (cons (vlax-curve-getParamAtPoint obj pt) pt) lstPtsPa) ) ))
);foreach
(if lstPtsPa
(setq lstPtsPa (vl-sort lstPtsPa '(lambda (x y) (> (car x) (car y))))
lstPts (mapcar 'cdr lstPtsPa) ))
(setq ent (vlax-vla-object->ename obj)
lstPtsPa nil)
(repeat (/ (length lstPts) 2)
(command "._break" ent "_non" (car lstPts) "_non" (cadr lstPts))
(setq lstPts (cddr lstPts)) )
)
)
(command "undo" "e")
(princ)
)


(defun TraceObject (obj / typlst
typ TracePline TraceACE
TraceLine TraceSpline TraceType1Pline
TraceType23Pline
)
(defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
(not (equal (car lst) (last lst) 1e-6))
)
(append lst (list (car lst)))
lst
)
)
(defun TracePline (obj / param endparam anginc
tparam pt blg ptlst delta inc
arcparam flag
)
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0))
)
(setq tparam param)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst))
)
(if (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg)
)
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc)
)
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam)
)
)
)
)
(setq param (1+ param))
)
(if (and (apply 'and ptlst)
(> (length ptlst) 1)
)
(ZClosed (reverse ptlst))
)
) ;end
(defun TraceACE (obj / startparam endparam
anginc delta div inc pt
ptlst
)
(setq startparam (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 5.0 180.0))
)
(if (equal endparam (* pi 2) 1e-12)
(setq delta endparam)
(setq delta (NormalAngle (- endparam startparam)))
)
(setq div (1+ (fix (/ delta anginc)))
inc (/ delta div)
)
(while (or
(< startparam endparam)
(equal startparam endparam 1e-12)
)
(setq pt (vlax-curve-getPointAtParam obj startparam)
ptlst (cons pt ptlst)
startparam (+ inc startparam)
)
)
(reverse ptlst)
);end defun
(defun TraceLine (obj)
(list (vlax-get obj 'StartPoint)
(vlax-get obj 'EndPoint)
)
)
(defun TraceSpline (obj / startparam endparam
ncpts inc param fd ptlst pt1
pt2 ang1 ang2 a
)
(setq startparam (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
ncpts (vlax-get obj 'NumberOfControlPoints)
inc (/ (- endparam startparam) (* ncpts 7))
param (+ inc startparam)
fd (vlax-curve-getfirstderiv obj param)
ptlst (cons (vlax-curve-getStartPoint obj) ptlst)
)
(while (< param endparam)
(setq pt1 (vlax-curve-getPointAtParam obj param)
ang1 fd
param (+ param inc)
pt2 (vlax-curve-getPointAtParam obj param)
fd (vlax-curve-getfirstderiv obj param)
ang2 fd
a (abs (3d_angw1w2 ang1 ang2))
)
(if (> a 0.00218166)
(setq ptlst (cons pt1 ptlst))
)
)
(if (not (equal
(setq pt1 (vlax-curve-getEndPoint obj))
(car ptlst)
1e-8
)
)
(setq ptlst (cons pt1 ptlst))
)
(reverse ptlst)
);end defun
(defun TraceType1Pline (obj / ptlst objlst lst)
(setq ptlst (list (vlax-curve-getStartPoint obj))
objlst (vlax-invoke obj 'Explode)
)
(foreach x objlst
(setq lst (TraceACE x))
(if (not (equal (car lst) (last ptlst) 1e-8))
(setq lst (reverse lst))
)
(setq ptlst (append ptlst (cdr lst)))
(vla-delete x)
)
(ZClosed ptlst)
);end defun
(defun TraceType23Pline (obj / objlst ptlst lastpt)
(setq objlst (vlax-invoke obj 'Explode)
lastpt (vlax-get (last objlst) 'EndPoint)
)
(foreach x objlst
(setq ptlst (cons (vlax-get x 'StartPoint) ptlst))
(vla-delete x)
)
(ZClosed (reverse (cons lastpt ptlst)))
);end defun
(defun Trace3DPline (obj / coord ptlst)
(setq coord (vlax-get obj 'Coordinates))
(repeat (/ (length coord) 3)
(setq
ptlst (cons (list (car coord) (cadr coord) (caddr coord))
ptlst
)
)
(setq coord (cdddr coord))
)
(ZClosed (reverse ptlst))
);end defun
(defun NormalAngle (a)
(if (numberp a)
(angtof (angtos a 0 14) 0)
)
)
(defun 3d_angw1w2 (Wekt1 Wekt2 / CosA)
(if (equal (setq CosA (/ (apply '+ (mapcar '* Wekt1 Wekt2))
(distance '(0 0 0) Wekt1)
(distance '(0 0 0) Wekt2)
)
)
-1.0
1e-6
)
Pi
(if (equal CosA 0.0 1e-6)
(* 0.5 PI)
(atan (sqrt (- 1 (* CosA CosA))) CosA)
)
)
)
(setq typlst '("AcDb2dPolyline" "AcDbPolyline"
"AcDb3dPolyline" "AcDbCircle"
"AcDbArc" "AcDbEllipse"
"AcDbSpline" "AcDbLine"
)
)
(or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj))
)
(setq typ (vlax-get obj 'ObjectName))
(if (vl-position typ typlst)
(cond
((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline"))
(cond
((or
(not (vlax-property-available-p obj 'Type))
(= 0 (vlax-get obj 'Type))
)
(TracePline obj)
)
((or (= 3 (vlax-get obj 'Type)) (= 2 (vlax-get obj 'Type)))
(TraceType23Pline obj)
)
((= 1 (vlax-get obj 'Type))
(TraceType1Pline obj)
)
)
)
((eq typ "AcDbLine") (TraceLine obj))
((or (eq typ "AcDbCircle")
(eq typ "AcDbArc")
(eq typ "AcDbEllipse")
)
(TraceACE obj)
)
((eq typ "AcDbSpline") (TraceSpline obj))
((eq typ "AcDb3dPolyline") (Trace3DPline obj))
)
)
)

  • 0

#513 trinhvqh

trinhvqh

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 408 Bài viết
Điểm đánh giá: 222 (khá)

Đã gửi 14 December 2009 - 01:36 PM

@gia_bach
Lại có chút trục trặc khi làm tương tự cho các lệnh khác (Lệnh 4,5,6,7 và qd)

Nhờ gia_bach kiểm tra và sửa lỗi giúp mình
Xin cảm ơn!!

http://www.cadviet.c...3dimmension.rar
  • 0

#514 master_worse

master_worse

    biết lệnh offset

  • Advance Member
  • PipPipPip
  • 170 Bài viết
Điểm đánh giá: 87 (tàm tạm)

Đã gửi 14 December 2009 - 01:51 PM

@gia_bach
Lại có chút trục trặc khi làm tương tự cho các lệnh khác (Lệnh 4,5,6,7 và qd)

Nhờ gia_bach kiểm tra và sửa lỗi giúp mình
Xin cảm ơn!!

http://www.cadviet.c...3dimmension.rar


thiếu ( trước các defun c:4(5,6,7 và qd)

ý quên! :(

Bài viết đã được chỉnh sửa nội dung bởi master_worse: 14 December 2009 - 02:01 PM

  • 1

Ngu dốt không đáng thẹn bằng thiếu ý chí học hỏi


Tri thức làm người ta khiêm tốn, ngu si làm người ta kiêu ngạo (Ngạn ngữ Anh)


#515 dvqkt112

dvqkt112

    biết zoom

  • Members
  • Pip
  • 10 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 14 December 2009 - 02:11 PM

Anh ơi, sau khi emchọn các đối tượng xong rồi thì không làm gì được nữa, nó báo là:
Command:
Chon doi tuong can Trim :
Select objects: Specify opposite corner: 3 found
Select objects: ; error: bad point argument.
Anh chỉ em cách sử dụng với.
  • 0

#516 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 December 2009 - 02:14 PM

thiếu ( trước các defun c:4(5,6,7 và qd)
ý quên! :(

to master_worse : quên cái gì ? :rolleyes:

@gia_bach
Lại có chút trục trặc khi làm tương tự cho các lệnh khác (Lệnh 4,5,6,7 và qd)

Nhờ gia_bach kiểm tra và sửa lỗi giúp mình
Xin cảm ơn!!

http://www.cadviet.c...3dimmension.rar

;CAC LENH VE DIMENSION
(defun c:1(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimlinear" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;------
(defun c:2(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_DIMALIGNED" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:3(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_DIMCONTINUE" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:4(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimbaseline" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:5(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimradius" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:6(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimdiameter" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:7(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "_dimangular" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;-----
(defun c:qd(/ ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 1)
(if (tblsearch "layer" "KT-Dim")
(setvar "CLAYER" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )

(command "QDIM" )
(while (= (getvar "CMDACTIVE") 1 ) (command pause) )
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)


Một cách khác : dùng hàm con (Code ngắn hơn)
;CAC LENH VE DIMENSION
(defun c:1() (VeDim "1"))
(defun c:2() (VeDim "2"))
(defun c:3() (VeDim "3"))
(defun c:4() (VeDim "4"))
(defun c:5() (VeDim "5"))
(defun c:6() (VeDim "6"))
(defun c:7() (VeDim "7"))
(defun c:qd() (VeDim "qd"))

(defun VeDim(input / ov vl)
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)); reset Sys Vars
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))

(setq vl '("clayer" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(setvar "cmdecho" 0)
(if (tblsearch "layer" "KT-Dim")
(setvar "clayer" "KT-Dim")
(command "-layer" "M" "KT-Dim" "" ) )
(setvar "cmdecho" 1)
(cond
((= input "1")(command "_dimlinear"))
((= input "2")(command "_dimaligned"))
((= input "3")(command "_dimcontinue"))
((= input "4")(command "_dimbaseline"))
((= input "5")(command "_dimradius"))
((= input "6")(command "_dimdiameter"))
((= input "7")(command "_dimangular"))
((= input "qd")(command "qdim"))
)
(while (= (getvar "CMDACTIVE") 1) (command pause))
(mapcar 'setvar vl ov) ; reset Sys Vars
(princ)
)
;---------------------------------

Bài viết đã được chỉnh sửa nội dung bởi gia_bach: 15 December 2009 - 11:03 AM

  • 1

#517 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1436 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 14 December 2009 - 02:19 PM

Anh ơi, sau khi emchọn các đối tượng xong rồi thì không làm gì được nữa, nó báo là:
Command:
Chon doi tuong can Trim :
Select objects: Specify opposite corner: 3 found
Select objects: ; error: bad point argument.
Anh chỉ em cách sử dụng với.

Lỗi do CODE quá dài ?!

Huớng dẫn sử dụng : http://www.cadviet.c...o...ost&p=81489
  • 1

#518 master_worse

master_worse

    biết lệnh offset

  • Advance Member
  • PipPipPip
  • 170 Bài viết
Điểm đánh giá: 87 (tàm tạm)

Đã gửi 14 December 2009 - 03:05 PM

to master_worse : quên cái gì ? :(
....

cái dzụ đích danh
-------------------
P/S:
sẵn đây ai biết cho mình hỏi làm sao xóa cái mình đã trả lời. ví dụ như mình đã trả lời ở trên giờ tiền bối gia_bạch trả lời cụ thể hơn thì xóa bài của mình đi cho thông thoáng. hay phải nhờ admin.
  • 0

Ngu dốt không đáng thẹn bằng thiếu ý chí học hỏi


Tri thức làm người ta khiêm tốn, ngu si làm người ta kiêu ngạo (Ngạn ngữ Anh)


#519 tieu_ngu_nhi_43

tieu_ngu_nhi_43

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 15 December 2009 - 09:03 AM

Chào anh Nguyen Hoanh!
Anh có lisp nào mà có thể copy hoặc move nhiểu đối tượng theo nhiều phương với cùng một khoảng cách được không ạ?
Cụ thể em move 1 đối tượng theo 1 phương với khoảng cách là 200. Em muốn move đối tượng khác theo phương khác cũng với khoảng cách là 200. Nhưng cứ phải nhập lại khoảng cách thì lâu quá. Em muốn xin lisp nào có thể move mà ko cần nhập lại khoảng cách.
Thanks anh nhiều!!! Chúc Cadviet ngày càng lớn mạnh.
  • 0

#520 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 15 December 2009 - 11:27 AM

Chào anh Nguyen Hoanh!
Anh có lisp nào mà có thể copy hoặc move nhiểu đối tượng theo nhiều phương với cùng một khoảng cách được không ạ?
Cụ thể em move 1 đối tượng theo 1 phương với khoảng cách là 200. Em muốn move đối tượng khác theo phương khác cũng với khoảng cách là 200. Nhưng cứ phải nhập lại khoảng cách thì lâu quá. Em muốn xin lisp nào có thể move mà ko cần nhập lại khoảng cách.
Thanks anh nhiều!!! Chúc Cadviet ngày càng lớn mạnh.

Chào bạn tieu_ngu_nhi_43,
Theo cái yêu cầu của bạn thì thực ra không nhất thiết phải dùng lisp đâu. Tuy nhiên nếu bạn vẫn thấy thích dùng lisp thì nó đây:

(defun c:mmo ()
(setq ss (ssget)
n (sslength ss)
i 0
d (getreal "\n Nhap khoang cach muon di chuyen: ")
)
(repeat n
(setq ent (ssname ss i)
ang (getangle "\n Nhap goc muon di chuyen: ")
)
(command "move" ent "" (setq p1 (getpoint "\n Chon diem tuy y ")) (polar p1 ang d))
(setq i (1+ i))
)
(princ)
)



Tuy nhiên khi dùng lisp này, bạn cần lưu ý như sau:
1/- Khi lisp nhắc bạn chọn đối tượng, bạn nên chọn bằng cách pick từng chú một nhé. Bởi vì như vậy may ra bạn còn nhớ được trật tự của các đối tượng để khi di chuyển khỏi nhầm lẫn. Nếu bạn sử dụng phương pháp chọn khác e rằng lisp này sẽ chạy không đúng ý bạn đâu.
2/- Khi lisp yêu cầu nhập góc muốn di chuyển của từng đối tượng, bạn hãy nhập góc theo hướng bạn muốn di chuyển với đơn vị đo là độ.
3/- Khi lisp nhắc bạn chọn điểm tùy ý, bạn có thể pick bất cứ điểm nào trên bản vẽ mà kết quả của chúng vẫn như nhau.
4/- Khoảng cách di chuyển của tất cả các đối tượng được yêu cầu nhập một lần khi bắt đầu chạy lisp.
5/- Không nên chạy lisp với quá nhiều đối tượng được lựa chọn vì như vậy có thể bạn sẽ chẳng nhớ nổi cái trật tự chọn ban đầu của bạn và thế là bạn sẽ di chuyển các đối tượng không đúng theo ý muốn của bạn.
6/-Bạn hãy dựa vào cái lisp này để tự mình điều chỉnh sao cho phù hợp nhất với yêu cầu của bạn.

Thú thực là mình chưa hoàn toàn hài lòng với cái lisp này, nhưng hy vọng bạn cũng như mọi người sẽ bổ sung cho hoàn thiện hơn.
Chúc bạn thành công.

PS: Mình bổ sung thêm một lisp khác với cùng chức năng như trên nhưng tránh được cái lỗi phải nhớ trật tự các đối tượng trong bộ chọn. Sau mỗi lần di chuyển một đối tượng lisp sẽ hỏi bạn có muốn tiếp tục hay không. Nếu bạn trả lời "y" lisp sẽ cho bạn di chuyển tiếp đối tượng khác, nếu bạn trả lời "n" lisp sẽ dừng chạy.
Lisp này có nhược điểm là nếu bạn muốn chuyển nhiều đối tượng theo cùng một hướng thì bạn phải làm nhiều lần.
Bạn hãy thử xem nhé.

(defun c:mmn ()
(setq d (getreal "\n Nhap khoang cach muon di chuyen: ")
ans (getstring "\n Ban muon di chuyen cac doi tuong ??? < y or n>: "))
(while (= ans "y")
(setq ent (car(entsel))
ang (getangle "\n Nhap goc muon di chuyen: "))
(command "move" ent "" (setq p1 (getpoint "\n Chon diem tuy y ")) (polar p1 ang d))
(setq ans (getstring "\n Ban co muon tiep tuc di chuyen??? < y or n>: "))
)
(princ)
)

  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.