Đến nội dung


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

Viết Lisp theo yêu cầu


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

#1821 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 09 April 2009 - 11:10 AM

Cám ơn ban q288 nhiệt tình giúp đỡ bọn mình . Chương trình chạy rất tuyệt ! Tuy nhiên thì mình cũng phát hiện ra lỗi đó không biết có đúng không bạn xem lại hộ mình nhé. mình thấy ngoài lỗi bắt chính xác ra, những lỗi kia nó bắt là do không tạo điểm point (end point) ở đó. layer 2 nó chỉ snap vào thì cũng được không cần endpoint ...Bạn chỉnh lại cho giúp mình xem có được không nhé ...


Mình tìm ra lỗi và sửa rồi. Chạy trong file_mau.dwg thì ok. Bạn thử chạy các file khác xem sao, chọn file lớn hơn và nhiều pline hơn để thử nhiều tình huống. CT sửa như sau:

(defun c:chk (/ os ss v0 v L p1 p2 ss1 n)

;;;Intersections of e1, e2. Return LIST of points
;;;Thank Mr. Hoanh for this function!
(defun ints (e1 e2 / ob1 ob2 V L1 L2)
(setq ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))
(if (/= (vlax-safearray-get-u-bound V 1) -1)
(progn
(setq L1 (vlax-safearray->list V)
L2 nil)
(while L1
(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))
(repeat 3 (setq L1 (cdr L1)))) )
(setq L2 nil))
L2
)

;;; Bat diem
(defun batd(a1 a2 / ss0 s i)
(setq ss0 (ssget "c" (polar a1 (* -0.25 pi) 0.01)
(polar a1 (* 0.75 pi) 0.01))
i 0
s (ssadd))
(repeat (sslength ss0)
(setq s (ssadd (ssname ss0 i) s)
i (1+ i)))
(setq ss0 (ssget "c" (polar a2 (* -0.25 pi) 0.01)
(polar a2 (* 0.75 pi) 0.01))
i 0)
(repeat (sslength ss0)
(setq s (ssadd (ssname ss0 i) s)
i (1+ i)))
s
)

;;; Main function
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setvar "CLAYER" "layer 2")
(setvar "CECOLOR" "1")
(command "zoom" "e")
(setq ss (ssget "X" '((8 . "layer 2")))
n 0)

(repeat (sslength ss)
(setq v0 (ssname ss n)
v (vlax-ename->vla-object v0)
L nil )

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")
(progn
(setq p1 (vlax-curve-getStartPoint v)
p2 (vlax-curve-getEndPoint v)
ss1 (batd p1 p2))

(if (and (= (sslength ss1) 1) (ssmemb v0 ss1))
(progn
(command "Point" p1)
(command "Point" p2))
(progn
(setq ss1 (ssdel v0 ss1))
(while (> (sslength ss1) 0)
(setq L (append L (ints v0 (ssname ss1 0)))
ss1 (ssdel (ssname ss1 0) ss1)))
(if (not (member p1 L)) (command "Point" p1))
(if (not (member p2 L)) (command "Point" p2))))))
(setq n (1+ n))
)
(setvar "OSMODE" os)
)
  • 2

#1822 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 09 April 2009 - 01:31 PM

Chào q288!
Cái này thì ok rồi nhưng mình muốn hoàn thiện hơn chút xíu bạn giúp mình với nha.
Mình muốn sau khi ghi kích thước thứ nhất thì mình có thể chọn tiếp các đoạn khác để ghi tiếp chứ không cần phải kích lệnh thêm lần nữa, vì mình cần tính chiều dài của nhiều đoạn mà mỗi lần lai đánh lệnh lại từ đầu, rồi nó lại hỏi preix and suffix thấy cũng bất tiện.
Nhân tiện cho mình hỏi thêm nha, hôm trước minh dung thì ok nhung mấy hôm nay dung thì nó ghi kích thước tại vị trí rất xa so với chỗ mình click (điểm cần ghi). Giúp mình với nhé!
Thank!
Chúc sức khoẻ!


Bạn muốn dùng vòng lặp thì mình sửa lại như dưới đây. Khi nào bạn muốn thoát ra vòng lặp thì đánh enter. Còn text nằm không đúng vị trí thì chắc do bạn đặt ucs khác với world, mình cũng thêm vào ct một dòng để chỉnh lại ucs.

;;;------------------------------------------------------------------------------------
(defun getTw ()
;;;Get current text width factor
(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun getTh (/ Th)
;;;Get current textheight or textsize
(if (= (setqTh (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
(getvar "textsize")
Th
)
)
;;;------------------------------------------------------------------------------------
(defun emkT (S p)
;;;Write text S at point p by entmake function
;;;Text style, heigh and width factor get from current values
(entmake (list (cons 0 "TEXT")
(cons 10 p)
(cons 40 (getTh))
(cons 41 (getTw))
(cons 1 S)
(cons 7 (getvar "textstyle"))
)
)
)
;;;------------------------------------------------------------------------------------
(defun calcL (e)
;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;------------------------------------------------------------------------------------
(defun C:CHD (/ Opt S1 S2 e p L)
(vl-load-com)
(command "ucs" "w")

(if (not preT) (setq preT "L="))
(if (not sufT) (setq sufT ""))
(setq S1 preT
S2 sufT)
(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

(initget "Y N")
(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))
(if (not Opt) (setq Opt "N"))
(if (= Opt "Y")
(setq S1 (getstring "\nPrefix :")
preT S1
S2 (getstring "\nSuffix :")
sufT S2))

(setq ss (ssget)
n 0
total 0)

(while ss
(repeat (sslength ss)
(setq e (ssname ss n)
L (calcL e)
total (+ total L)
n (1+ n))
)
(setq p (getpoint "\nBase point: "))
(emkT S1 p)
(emkT (strcat " " (rtos total) S2) p)
(setq ss (ssget)
n 0
total 0)
)
(princ)
)
  • 0

#1823 m.rduong

m.rduong

    biết zoom

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

Đã gửi 09 April 2009 - 01:45 PM

Mình tìm ra lỗi và sửa rồi. Chạy trong file_mau.dwg thì ok. Bạn thử chạy các file khác xem sao, chọn file lớn hơn và nhiều pline hơn để thử nhiều tình huống. CT sửa như sau:

(defun c:chk (/ os ss v0 v L p1 p2 ss1 n)

;;;Intersections of e1, e2. Return LIST of points
;;;Thank Mr. Hoanh for this function!
(defun ints (e1 e2 / ob1 ob2 V L1 L2)
(setq ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendBoth)))
(if (/= (vlax-safearray-get-u-bound V 1) -1)
(progn
(setq L1 (vlax-safearray->list V)
L2 nil)
(while L1
(setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1)))))
(repeat 3 (setq L1 (cdr L1)))) )
(setq L2 nil))
L2
)

;;; Bat diem
(defun batd(a1 a2 / ss0 s i)
(setq ss0 (ssget "c" (polar a1 (* -0.25 pi) 0.01)
(polar a1 (* 0.75 pi) 0.01))
i 0
s (ssadd))
(repeat (sslength ss0)
(setq s (ssadd (ssname ss0 i) s)
i (1+ i)))
(setq ss0 (ssget "c" (polar a2 (* -0.25 pi) 0.01)
(polar a2 (* 0.75 pi) 0.01))
i 0)
(repeat (sslength ss0)
(setq s (ssadd (ssname ss0 i) s)
i (1+ i)))
s
)

;;; Main function
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setvar "CLAYER" "layer 2")
(setvar "CECOLOR" "1")
(command "zoom" "e")
(setq ss (ssget "X" '((8 . "layer 2")))
n 0)

(repeat (sslength ss)
(setq v0 (ssname ss n)
v (vlax-ename->vla-object v0)
L nil )

(if (= (cdr (assoc 0 (entget v0))) "LWPOLYLINE")
(progn
(setq p1 (vlax-curve-getStartPoint v)
p2 (vlax-curve-getEndPoint v)
ss1 (batd p1 p2))

(if (and (= (sslength ss1) 1) (ssmemb v0 ss1))
(progn
(command "Point" p1)
(command "Point" p2))
(progn
(setq ss1 (ssdel v0 ss1))
(while (> (sslength ss1) 0)
(setq L (append L (ints v0 (ssname ss1 0)))
ss1 (ssdel (ssname ss1 0) ss1)))
(if (not (member p1 L)) (command "Point" p1))
(if (not (member p2 L)) (command "Point" p2))))))
(setq n (1+ n))
)
(setvar "OSMODE" os)
)


Chào q288 lisp này của bạn bi lỗi khi đánh lệnh nhu sau :

Command: chk
zoom
Specify corner of window, enter a scale factor (nX or nXP), or
[All/Center/Dynamic/Extents/Previous/Scale/Window/Object] : e
Command: ; error: no function definition: VLAX-ENAME->VLA-OBJECT

Mình chạy trên cad2006 thì ok nhưng sang bên cad 2008 thì nó báo lỗi nhu vậy và sang một số máy cad khác cao hơn 2006 nó cũng báo lỗi nh vậy ...Bạn xem cho mình voi nhé ! Mình cũng đang cần cái nay lắm.
  • 0

#1824 conghoan1003

conghoan1003

    biết vẽ point

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

Đã gửi 09 April 2009 - 01:56 PM

Bạn muốn dùng vòng lặp thì mình sửa lại như dưới đây. Khi nào bạn muốn thoát ra vòng lặp thì đánh enter. Còn text nằm không đúng vị trí thì chắc do bạn đặt ucs khác với world, mình cũng thêm vào ct một dòng để chỉnh lại ucs.

;;;------------------------------------------------------------------------------------
(defun getTw ()
;;;Get current text width factor
(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun getTh (/ Th)
;;;Get current textheight or textsize
(if (= (setqTh (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
(getvar "textsize")
Th
)
)
;;;------------------------------------------------------------------------------------
(defun emkT (S p)
;;;Write text S at point p by entmake function
;;;Text style, heigh and width factor get from current values
(entmake (list (cons 0 "TEXT")
(cons 10 p)
(cons 40 (getTh))
(cons 41 (getTw))
(cons 1 S)
(cons 7 (getvar "textstyle"))
)
)
)
;;;------------------------------------------------------------------------------------
(defun calcL (e)
;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;------------------------------------------------------------------------------------
(defun C:CHD (/ Opt S1 S2 e p L)
(vl-load-com)
(command "ucs" "w")

(if (not preT) (setq preT "L="))
(if (not sufT) (setq sufT ""))
(setq S1 preT
S2 sufT)
(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

(initget "Y N")
(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))
(if (not Opt) (setq Opt "N"))
(if (= Opt "Y")
(setq S1 (getstring "\nPrefix :")
preT S1
S2 (getstring "\nSuffix :")
sufT S2))

(setq ss (ssget)
n 0
total 0)

(while ss
(repeat (sslength ss)
(setq e (ssname ss n)
L (calcL e)
total (+ total L)
n (1+ n))
)
(setq p (getpoint "\nBase point: "))
(emkT S1 p)
(emkT (strcat " " (rtos total) S2) p)
(setq ss (ssget)
n 0
total 0)
)
(princ)
)

Chào q288!
Dùng cái này khi mình kích điểm thì nó lại báo lối thế này: Base point: ; error: no function definition: SETQTH
Giúp mình nhé!
Thank!
  • 0
Học học nữa học mãi.
Đúp học lại!

#1825 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 09 April 2009 - 02:16 PM

Chào q288 lisp này của bạn bi lỗi khi đánh lệnh nhu sau :

Command: chk
zoom
Specify corner of window, enter a scale factor (nX or nXP), or
[All/Center/Dynamic/Extents/Previous/Scale/Window/Object] : e
Command: ; error: no function definition: VLAX-ENAME->VLA-OBJECT

Mình chạy trên cad2006 thì ok nhưng sang bên cad 2008 thì nó báo lỗi nhu vậy và sang một số máy cad khác cao hơn 2006 nó cũng báo lỗi nh vậy ...Bạn xem cho mình voi nhé ! Mình cũng đang cần cái nay lắm.


Bạn thêm dòng (vl-load-com) ở đầu ct thì sẽ chạy tốt.
  • 0

#1826 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 09 April 2009 - 02:20 PM

Chào q288!
Dùng cái này khi mình kích điểm thì nó lại báo lối thế này: Base point: ; error: no function definition: SETQTH
Giúp mình nhé!
Thank!


sorry, khi viết lại mình vô tình xóa space nên bị báo lỗi như trên. Bạn chép lại ct nhé.

;;;------------------------------------------------------------------------------------
(defun getTw ()
;;;Get current text width factor
(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun getTh (/ Th)
;;;Get current textheight or textsize
(if (= (setq Th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
(getvar "textsize")
Th
)
)
;;;------------------------------------------------------------------------------------
(defun emkT (S p)
;;;Write text S at point p by entmake function
;;;Text style, heigh and width factor get from current values
(entmake (list (cons 0 "TEXT")
(cons 10 p)
(cons 40 (getTh))
(cons 41 (getTw))
(cons 1 S)
(cons 7 (getvar "textstyle"))
)
)
)
;;;------------------------------------------------------------------------------------
(defun calcL (e)
;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;------------------------------------------------------------------------------------
(defun C:CHD (/ Opt S1 S2 e p L)
(vl-load-com)
(command "ucs" "w")

(if (not preT) (setq preT "L="))
(if (not sufT) (setq sufT ""))
(setq S1 preT
S2 sufT)
(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

(initget "Y N")
(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))
(if (not Opt) (setq Opt "N"))
(if (= Opt "Y")
(setq S1 (getstring "\nPrefix :")
preT S1
S2 (getstring "\nSuffix :")
sufT S2))

(setq ss (ssget)
n 0
total 0)

(while ss
(repeat (sslength ss)
(setq e (ssname ss n)
L (calcL e)
total (+ total L)
n (1+ n))
)
(setq p (getpoint "\nBase point: "))
(emkT S1 p)
(emkT (strcat " " (rtos total) S2) p)
(setq ss (ssget)
n 0
total 0)
)
(princ)
)
  • 0

#1827 conghoan1003

conghoan1003

    biết vẽ point

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

Đã gửi 09 April 2009 - 04:06 PM

Chào cả nhà!
Cho mình hỏi ai có lisp cộng (trừ) tất cả các số được chọn thêm một giá trị nào đó không? Cho mình xin với. Hiện mình đang dung lisp này, nó cũng có thể cộng được nhưng không hiểu tại sao nó lại có sai số khi sử dụng.
Thank!
(defun doiphay_cham ()
(setq st_ch "")
(setq count_st 1)
(if ( = (substr st_chang 1 1) ".")
(setq st_chang (strcat "P" st_chang ))
nil
)
(princ st_chang)
(repeat (strlen st_chang)
(Progn
(setq char_single (substr st_chang count_st 1))
(if (= char_single ",") (setq char_single ".") nil )
(setq st_ch (strcat st_ch char_single))
(setq count_st (+ count_st 1))
)
)
(setq st_chang st_ch)
)
(defun doicham_phay ()
(setq int_ch (fix (abs h_numadd)))
(setq frac_ch (fix (* ( - (abs h_numadd) (abs int_ch)) 100) ))
(princ frac_ch)
(If (< frac_ch 10)
(setq nt (strcat (itoa int_ch) ",0" (itoa frac_ch)))
(setq nt (strcat (itoa int_ch) "," (itoa frac_ch)))
)
(if ( < h_numadd 0) (setq nt (strcat "-" nt)) nil )
)
(defun chtxt (/ sset opt ssl nsset temp unctr ct_ver cht_er cht_oe
sslen style hgt rot txt ent cht_oc cht_ot cht_oh
loc loc1 justp justq orthom )

(setq ct_ver "1.02") ; Reset this local if you make a change.
;;
;; Internal error handler defined locally
;;
(defun cht_er (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(if (/= s "Function cancelled")
(if (= s "quit / exit abort")
(princ)
(princ (strcat "\nError: " s))
)
)
(eval(read U:E))
(if cht_oe ; If an old error routine exists
(setq *error* cht_oe) ; then, reset it
)
(if temp (redraw temp 1))
(if cht_oc (setvar "cmdecho" cht_oc)) ; Reset command echoing
(if cht_ot (setvar "texteval" cht_ot))
(if cht_oh (setvar "highlight" cht_oh))
(princ)
)
;;
;; Body of function
;;
(if *error* ; Set our new error handler
(setq cht_oe *error* *error* cht_er)
(setq *error* cht_er)
)

;; Set undo groups and ends with (eval(read U:G)) or (eval(read U:E))
(setq U:G "(command \"undo\" \"group\")"
U:E "(command \"undo\" \"en\")"
)

(setq cht_oc (getvar "cmdecho"))
(setq cht_oh (getvar "highlight"))
(setvar "cmdecho" 0)

(eval(read U:G))

(princ (strcat "\nChange text, Version " ct_ver
", © 1990-1991 by Autodesk, Inc. "))
(prompt "\nSelect text to change. ")
(setq sset (ssget))
(if (null sset)
(progn
(princ "\nERROR: Nothing selected.")
(exit)
)
)
;; Verify the entity set.
(cht_ve)
;; This is the main option loop.
(cht_ol)

(if cht_oe (setq *error* cht_oe)) ; Reset old error function if error
(eval(read U:E))
(if cht_ot (setvar "texteval" cht_ot))
(if cht_oh (setvar "highlight" cht_oh))
(if cht_oc (setvar "cmdecho" cht_oc)) ; Reset command echoing
(princ)
)
;;;
;;; Verify and sort out non-text entities from the selection set.
;;;
(defun cht_ve ()
(setq ssl (sslength sset)
nsset (ssadd))
(if (> ssl 25)
(princ "\nVerifying the selected entities -- please wait. ")
)
(while (> ssl 0)
(setq temp (ssname sset (setq ssl (1- ssl))))
(if (= (cdr(assoc 0 (entget temp))) "TEXT")
(ssadd temp nsset)
)
)
(setq ssl (sslength nsset)
sset nsset
unctr 0
)
(print ssl)
(princ "text entities found. ")
)
;;;
;;; The option loop.
;;;
(defun cht_ol ()
(setq opt T)
(while (and opt (> ssl 0))
(setq unctr (1+ unctr))
(command "_.UNDO" "_GROUP")
; (initget "Location Justification Style Height Rotation Width Text Undo")
; (setq opt (getkword
; "\nHeight/Justification/Location/Rotation/Style/Text/Undo/Width: "))
(setq opt "Text")
(if opt
(cond
((= opt "Undo")
(cht_ue) ; Undo the previous command.
)
((= opt "Location")
(cht_le) ; Change the location.
)
((= opt "Justification")
(cht_je) ; Change the justification.
)
((= opt "Style") (cht_pe "Style" "style name" 7) )
((= opt "Height") (cht_pe "Height" "height" 40) )
((= opt "Rotation") (cht_pe "Rotation" "rotation angle" 50) )
((= opt "Width") (cht_pe "Width" "width factor" 41) )
((= opt "Text")
(cht_te) ; Change the text.
)
)
(setq opt nil)
)
(command "_.UNDO" "_END")
)
)
;;;
;;; Undo an entry.
;;;
(defun cht_ue ()
(if (> unctr 1)
(progn
(command "_.UNDO" "_END")
(command "_.UNDO" "2")
(setq unctr (- unctr 2))
)
(progn
(princ "\nNothing to undo. ")
(setq unctr (- unctr 1))
)
)
)
;;;
;;; Change the location of an entry.
;;;
(defun cht_le ()
(setq sslen (sslength sset)
style ""
hgt ""
rot ""
txt ""
)
(command "_.CHANGE" sset "" "")
(while (> sslen 0)
(setq ent (entget(ssname sset (setq sslen (1- sslen))))
opt (list (cadr (assoc 11 ent))
(caddr (assoc 11 ent))
(cadddr (assoc 11 ent)))
)
(prompt "\nNew text location: ")
(command pause)
(if (null loc)
(setq loc opt)
)
(command style hgt rot txt)
)
(command)
)
;;;
;;; Change the justification of an entry.
;;;
(defun cht_je ()
(if (getvar "DIMCLRD")
(initget (strcat "TLeft TCenter TRight "
"MLeft MCenter MRight "
"BLeft BCenter BRight "
"Aligned Center Fit Left Middle Right ?"))
(initget "Aligned Center Fit Left Middle Right ?")
)
(setq sslen (sslength sset))
(setq justp (getkword (strcat "\nJustification point(s) - "
"Aligned/Center/Fit/Left/Middle/Right/: ")))
(cond
((= justp "Left") (setq justp 0 justq 0) )
((= justp "Center") (setq justp 1 justq 0) )
((= justp "Right") (setq justp 2 justq 0) )
((= justp "Aligned") (setq justp 3 justq 0) )
((= justp "Fit") (setq justp 5 justq 0) )
((= justp "TLeft") (setq justp 0 justq 3) )
((= justp "TCenter") (setq justp 1 justq 3) )
((= justp "TRight") (setq justp 2 justq 3) )
((= justp "MLeft") (setq justp 0 justq 2) )
((= justp "Middle") (setq justp 4 justq 0) )
((= justp "MCenter") (setq justp 1 justq 2) )
((= justp "MRight") (setq justp 2 justq 2) )
((= justp "BLeft") (setq justp 0 justq 1) )
((= justp "BCenter") (setq justp 1 justq 1) )
((= justp "BRight") (setq justp 2 justq 1) )
((= justp "?") (setq justp nil) )
(T (setq justp nil) )
)
(if justp
(justpt) ; Process them...
(justpn) ; List options...
)
(command)
)
;;;
;;; Get alignment points for "aligned" or "fit" text.
;;;
(defun justpt ()
(while (> sslen 0)
(setq ent (entget(ssname sset (setq sslen (1- sslen))))
ent (subst (cons 72 justp) (assoc 72 ent) ent)
opt (trans (list (cadr (assoc 11 ent))
(caddr (assoc 11 ent))
(cadddr (assoc 11 ent)))
(cdr(assoc -1 ent)) ; from ECS
1) ; to current UCS
)
(if (getvar "DIMCLRD")
(setq ent (subst (cons 73 justq) (assoc 73 ent) ent))
)
(cond
((or (= justp 3) (= justp 5))
(prompt "\nNew text alignment points: ")
(if (= (setq orthom (getvar "orthomode")) 1)
(setvar "orthomode" 0)
)
(redraw (cdr(assoc -1 ent)) 3)
(initget 1)
(setq loc (getpoint))
(initget 1)
(setq loc1 (getpoint loc))
(redraw (cdr(assoc -1 ent)) 1)
(setvar "orthomode" orthom)
(setq ent (subst (cons 10 loc) (assoc 10 ent) ent))
(setq ent (subst (cons 11 loc1) (assoc 11 ent) ent))
)
((or (/= justp 0) (/= justq 0))
(redraw (cdr(assoc -1 ent)) 3)
(prompt "\nNew text location: ")
(if (= (setq orthom (getvar "orthomode")) 1)
(setvar "orthomode" 0)
)
(setq loc (getpoint opt))
(setvar "orthomode" orthom)
(redraw (cdr(assoc -1 ent)) 1)
(if (null loc)
(setq loc opt)
(setq loc (trans loc 1 (cdr(assoc -1 ent))))
)
(setq ent (subst (cons 11 loc) (assoc 11 ent) ent))
)
)
(entmod ent)
)
)
;;;
;;; List the options.
;;;
(defun justpn ()
(if (getvar "DIMCLRD") (textpage))
(princ "\nAlignment options: ")
(princ "\n\t TLeft TCenter TRight ")
(princ "\n\t MLeft MCenter MRight ")
(princ "\n\t BLeft BCenter BRight ")
(princ "\n\t Left Center Right")
(princ "\n\tAligned Middle Fit")
(if (not (getvar "DIMCLRD")) (textscr))
(princ "\n\nPress any key to return to your drawing. ")
(grread)
(princ "\r ")
(graphscr)
)
;;;
;;; Change the text of an entity.
;;;
(defun cht_te ()
(setq sslen (sslength sset))
; (initget "Globally Individually Retype")
; (princ " thu 1 them hang so.")
; (setq ans (getkword
; "\nSearch and replace text. Individually/Retype/:"))
(setq ans "Retype")
(setq cht_ot (getvar "texteval"))
(setvar "texteval" 1)
(cond
((= ans "Individually")
(if (= (getvar "popups") 1)
(progn
(initget "Yes No")
(princ "CHUYEN DOI TEXT + them hang so.")
(setq ans (getkword "\nEdit text in dialogue? :"))
)
(setq ans "No")
)

(while (> sslen 0)
(redraw (setq sn (ssname sset (setq sslen (1- sslen)))) 3)
(setq ss (ssadd))
(ssadd (ssname sset sslen) ss)
(if (= ans "No")
(chgtext ss)
(command "_.DDEDIT" sn "")
)
(redraw sn 1)
)
)
((= ans "Retype")
(setq h_add (getreal "So cong them : "))
(while (> sslen 0)
(setq ent (entget(ssname sset (setq sslen (1- sslen)))))
(redraw (cdr(assoc -1 ent)) 3)
(prompt (strcat "\nOld text: " (cdr(assoc 1 ent))))
; (setq nt (getstring T "\nNew text: ")) thay bang su ly cong them
(setq st_chang (strcat (cdr(assoc 1 ent))))
(setq st_save st_chang)
(doiphay_cham)
(setq h_num (atof st_chang))
(if (= h_num 0)
(setq nt st_save)
(progn
(setq h_numadd (+ h_num h_add))
(doicham_phay)
; (setq nt (rtos h_numadd 2 2))
)
)
(redraw (cdr(assoc -1 ent)) 1)
(if (> (strlen nt) 0)
(entmod (subst (cons 1 nt) (assoc 1 ent) ent))
)
)
)
(T
(chgtext sset) ; Change 'em all
)
)
(setq ans nil)
(setq opt nil)
(setvar "texteval" cht_ot)
)
;;;
;;; The old CHGTEXT command - rudimentary text editor
;;;
;;;
(defun C:CHGTEXT () (chgtext nil))

(defun chgtext (objs / last_o tot_o ent o_str n_str st s_temp
n_slen o_slen si chf chm cont ans)
(if (null objs)
(setq objs (ssget)) ; Select objects if running standalone
)
(setq chm 0)
(if objs
(progn ; If any objects selected
(if (= (type objs) 'ENAME)
(progn
(setq ent (entget objs))
(princ (strcat "\nExisting string: " (cdr (assoc 1 ent))))
)
(if (= (sslength objs) 1)
(progn
(setq ent (entget (ssname objs 0)))
(princ (strcat "\nExisting string: " (cdr (assoc 1 ent))))
)
)
)
(setq o_str (getstring "\nMatch string : " t))
(setq o_slen (strlen o_str))
(if (/= o_slen 0)
(progn
(setq n_str (getstring "\nNew string : " t))
(setq n_slen (strlen n_str))
(setq last_o 0
tot_o (if (= (type objs) 'ENAME)
1
(sslength objs)
)
)
(while (< last_o tot_o) ; For each selected object...
(if (= "TEXT" ; Look for TEXT entity type (group 0)
(cdr (assoc 0 (setq ent (entget (ssname objs last_o))))))
(progn
(setq chf nil si 1)
(setq s_temp (cdr (assoc 1 ent)))
(while (= o_slen (strlen (setq st (substr s_temp si o_slen))))
(if (= st o_str)
(progn
(setq s_temp (strcat
(if (> si 1)
(substr s_temp 1 (1- si))
""
)
n_str
(substr s_temp (+ si o_slen))
)
)
(setq chf t) ; Found old string
(setq si (+ si n_slen))
)
(setq si (1+ si))
)
)
(if chf
(progn ; Substitute new string for old
; Modify the TEXT entity
(entmod (subst (cons 1 s_temp) (assoc 1 ent) ent))
(setq chm (1+ chm))
)
)
)
)
(setq last_o (1+ last_o))
)
)
;; else go on to the next line...
)
)
)
(if (/= (type objs) 'ENAME)
(if (/= (sslength objs) 1) ; Print total lines changed
(princ (strcat "Changed "
(rtos chm 2 0)
" text lines."
)
)
)
)
(terpri)
)
;;;
;;; Main procedure for manipulating text entities
;;; ARGUMENTS:
;;; typ -- Type of operation to perform
;;; prmpt -- Partial prompt string to insert in standard prompt line
;;; fld -- Assoc field to be changed
;;; GLOBALS:
;;; sset -- The selection set of text entities
;;;
(defun cht_pe (typ prmpt fld / temp ow nw ent tw sty w hw lw
sslen n sn ssl)
(if (= (sslength sset) 1) ; Special case if there is only
; one entity selected
;; Process one entity.
(cht_p1)
;; Else
(progn
;; Set prompt string.
(cht_sp)
(if (= nw "List")
;; Process List request.
(cht_pl)
(if (= nw "Individual")
;; Process Individual request.
(cht_pi)
(if (= nw "Select")
;; Process Select request.
(cht_ps)
;; Else
(progn
(if (= typ "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(if (= (type nw) 'STR)
(if (not (tblsearch "style" nw))
(progn
(princ (strcat "\nStyle " nw " not found. "))
)
(cht_pa)
)
(cht_pa)
)
)
)
)
)
)
)
)
;;;
;;; Change all of the entities in the selection set.
;;;
(defun cht_pa (/ cht_oh temp)
(setq sslen (sslength sset))
(setq cht_oh (getvar "highlight"))
(setvar "highlight" 0)
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)

)
(setvar "highlight" cht_oh)
)
;;;
;;; Change one text entity.
;;;
(defun cht_p1 ()
(setq temp (ssname sset 0))
(setq ow (cdr(assoc fld (entget temp))))
(if (= opt "Rotation")
(setq ow (/ (* ow 180.0) pi))
)
(redraw (cdr(assoc -1 (entget temp))) 3)
(initget 0)
(if (= opt "Style")
(setq nw (getstring (strcat "\nNew " prmpt ". <"
ow ">: ")))
(setq nw (getreal (strcat "\nNew " prmpt ". <"
(rtos ow 2) ">: ")))
)
(if (or (= nw "") (= nw nil))
(setq nw ow)
)
(redraw (cdr(assoc -1 (entget temp))) 1)
(if (= opt "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(if (= opt "Style")
(if (null (tblsearch "style" nw))
(princ (strcat "\nStyle " nw " not found. "))

(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
)
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
)
)
;;;
;;; Set the prompt string.
;;;
(defun cht_sp ()
(if (= typ "Style")
(progn
(initget "Individual List New Select ")
(setq nw (getkword (strcat "\nIndividual/List/Select style/ prmpt
" for all text entities>: ")))
(if (or (= nw "") (= nw nil) (= nw "Enter"))
(setq nw (getstring (strcat "\nNew "
prmpt
" for all text entities: ")))
)
)
(progn
(initget "List Individual" 1)
(setq nw (getreal (strcat "\nIndividual/List/ prmpt
" for all text entities>: ")))
)
)
)
;;;
;;; Process List request.
;;;
(defun cht_pl ()
(setq unctr (1- unctr))
(setq sslen (sslength sset))
(setq tw 0)
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(if (= typ "Style")
(progn
(if (= tw 0)
(setq tw (list (cdr(assoc fld (entget temp)))))
(progn
(setq sty (cdr(assoc fld (entget temp))))
(if (not (member sty tw))
(setq tw (append tw (list sty)))
)
)
)
)
(progn
(setq tw (+ tw (setq w (cdr(assoc fld (entget temp))))))
(if (= (sslength sset) (1+ sslen)) (setq lw w hw w))
(if (< hw w) (setq hw w))
(if (> lw w) (setq lw w))
)
)
)
(if (= typ "Rotation")
(setq tw (* (/ tw pi) 180.0)
lw (* (/ lw pi) 180.0)
hw (* (/ hw pi) 180.0))
)
(if (= typ "Style")
(progn
(princ (strcat "\n"
typ
"(s) -- "))
(princ tw)
)
(princ (strcat "\n"
typ
" -- Min: "
(rtos lw 2)
"\t Max: "
(rtos hw 2)
"\t Avg: "
(rtos (/ tw (sslength sset)) 2) ))
)
)
;;;
;;; Process Individual request.
;;;
(defun cht_pi ()
(setq sslen (sslength sset))
(while (> sslen 0)
(setq temp (ssname sset (setq sslen (1- sslen))))
(setq ow (cdr(assoc fld (entget temp))))
(if (= typ "Rotation")
(setq ow (/ (* ow 180.0) pi))
)
(initget 0)
(redraw (cdr(assoc -1 (entget temp))) 3)
(if (= typ "Style")
(progn
(setq nw (getstring (strcat "\nNew "
prmpt
". <"
ow ">: ")))
)
(progn
(setq nw (getreal (strcat "\nNew "
prmpt
". <"
(rtos ow 2) ">: ")))
)
)
(if (or (= nw "") (= nw nil))
(setq nw ow)
)
(if (= typ "Rotation")
(setq nw (* (/ nw 180.0) pi))
)
(entmod (subst (cons fld nw)
(assoc fld (setq ent (entget temp)))
ent
)
)
(redraw (cdr(assoc -1 (entget temp))) 1)
)
)
;;;
;;; Process the Select option.
;;;
(defun cht_ps ()
(princ "\nSearch for which Style name? <*>: ")
(setq sn (strcase (getstring))
n -1
nsset (ssadd)
ssl (1- (sslength sset))
)
(if (or (= sn "*") (null sn) (= sn ""))
(setq nsset sset sn "*")
(while (and sn (< n ssl))
(setq temp (ssname sset (setq n (1+ n))))
(if (= (cdr(assoc 7 (entget temp))) sn)
(ssadd temp nsset)
)
)
)
(setq ssl (sslength nsset))
(princ "\nFound ")
(princ ssl)
(princ " text entities with STYLE of ")
(princ sn)
(princ ". ")
)
;;;
;;; The C: function definition.
;;;
(defun c:cta () (chtxt))
(princ "\ Chuong trinh cong caodo vao String , bat dau lenh voi CTA.")
(princ)
  • 0
Học học nữa học mãi.
Đúp học lại!

#1828 conghoan1003

conghoan1003

    biết vẽ point

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

Đã gửi 09 April 2009 - 04:22 PM

sorry, khi viết lại mình vô tình xóa space nên bị báo lỗi như trên. Bạn chép lại ct nhé.

;;;------------------------------------------------------------------------------------
(defun getTw ()
;;;Get current text width factor
(cdr (assoc 41 (tblsearch "style" (getvar "textstyle"))))
)
;;;------------------------------------------------------------------------------------
(defun getTh (/ Th)
;;;Get current textheight or textsize
(if (= (setq Th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
(getvar "textsize")
Th
)
)
;;;------------------------------------------------------------------------------------
(defun emkT (S p)
;;;Write text S at point p by entmake function
;;;Text style, heigh and width factor get from current values
(entmake (list (cons 0 "TEXT")
(cons 10 p)
(cons 40 (getTh))
(cons 41 (getTw))
(cons 1 S)
(cons 7 (getvar "textstyle"))
)
)
)
;;;------------------------------------------------------------------------------------
(defun calcL (e)
;;;Calculate length of Line, Pline, 3dPoly, Spline, Circle, Arc, Polygon
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;------------------------------------------------------------------------------------
(defun C:CHD (/ Opt S1 S2 e p L)
(vl-load-com)
(command "ucs" "w")

(if (not preT) (setq preT "L="))
(if (not sufT) (setq sufT ""))
(setq S1 preT
S2 sufT)
(prompt (strcat "\nMeasure and write length. Current prefix:[" preT "]\tSuffix:[" sufT "]"))

(initget "Y N")
(setq Opt (getkword "\nChange prefix and suffix? [Yes/No] :"))
(if (not Opt) (setq Opt "N"))
(if (= Opt "Y")
(setq S1 (getstring "\nPrefix :")
preT S1
S2 (getstring "\nSuffix :")
sufT S2))

(setq ss (ssget)
n 0
total 0)

(while ss
(repeat (sslength ss)
(setq e (ssname ss n)
L (calcL e)
total (+ total L)
n (1+ n))
)
(setq p (getpoint "\nBase point: "))
(emkT S1 p)
(emkT (strcat " " (rtos total) S2) p)
(setq ss (ssget)
n 0
total 0)
)
(princ)
)

Chào q288!
Bây giờ thì quá tuyệt rồi. Cảm ơn bạn nhiều nha!
  • 0
Học học nữa học mãi.
Đúp học lại!

#1829 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 09 April 2009 - 04:23 PM

Chào cả nhà!
Cho mình hỏi ai có lisp cộng (trừ) tất cả các số được chọn thêm một giá trị nào đó không? Cho mình xin với. Hiện mình đang dung lisp này, nó cũng có thể cộng được nhưng không hiểu tại sao nó lại có sai số khi sử dụng.
Thank!

Bạn đọc bài viết này. Không những Lisp cộng các text số mà còn loại bỏ các text chữ khi chọn đối tượng là text.
http://www.cadviet.c...amp;#entry32619
  • 0

#1830 thanhlichtran

thanhlichtran

    Chưa sử dụng CAD

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

Đã gửi 09 April 2009 - 06:42 PM

[quote name='q288' date='Apr 9 2009, 11:10' post='55174']
Mình tìm ra lỗi và sửa rồi. Chạy trong file_mau.dwg thì ok. Bạn thử chạy các file khác xem sao, chọn file lớn hơn và nhiều pline hơn để thử nhiều tình huống. CT sửa như sau:

Rất tuyệt ! Cảm ơn Diễn đàn Cảm ơn q288 nhiều lắm bạn rất nhiệt tình chương trình chạy ổn lắm . Thank you vẻy much !
  • 0

#1831 nguyenkhoadung98

nguyenkhoadung98

    biết vẽ pline

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

Đã gửi 10 April 2009 - 01:24 PM

Chào bạn nguyenkhoadung98,
Rất vui vì thấy bạn dùng được cái lisp của mình. Về cái vụ vị trí text thì quả thực là mình cũng đang hơi rối, chưa tìm được giải pháp bạn ạ. Còn cái text T2/L1-1A thực ra chỉ khó nếu như bạn đã đặt nó vào đường chuẩn rồi thôi. Nếu như bạn chưa đặt nó vào thì như mình đã viết trong bài trước, chỉ chỉnh tí xíu là OK ngay. Tại mình cứ theo cái hình bạn post lên nên sợ có hai cột cùng số đó mà thôi. Nếu như bạn đặt cái text ấy và cái block d0 ra ngoài đường chuẩn thì mình đã sửa cái lisp rồi. Bạn sửa như sau nhé:
1/- Trong các dòng code (setq t4 (+ i (atoi t2) 1)) bạn xóa béng cái con số 1 đi. Nhớ là chỉ xóa số 1 chứ đừng xóa đi bất cứ dấu ngoặc nào nha.
2/- Trong các dòng code (if (= 0 (rem i 3)) bạn thay số 1 vào vị trí số 0
3/- Trong các dòng code (if (= 1 (rem i 3)) bạn thay số 2 vào vị trí số 1
Lúc này kết quả chạy ra sẽ có các text bắt đầu là T2/L1-1A và tăng dần đến cuối cùng như bạn muốn. Và như vậy bạn có thể chọn điểm bắt đấu từ bất cứ vị trí nào trên đường chuẩn của bạn, các block cột sẽ được bắt đầu chèn từ vị trí đó theo hướng từ trái qua phải bạn ạ.

Về cái việc đòi tiên thì ai chả muốn. Mình cũng muốn lắm chớ. Mỗi tội hơi khó kiếm thôi bạn ạ. Cái cô tiên bạn muốn hơi khó tính đấy. Này nhé:
1/- Vì các block đã được chèn sẵn rồi nên việc xác định thứ tự các block này không hề đơn giản bạn ạ. Nhất là khi bản vẽ lại do người khác cung cấp. Đấy cũng chính là lý do mà cái lisp của bạn lại yêu cầu người dùng phải nhập lại thứ tự các điểm chèn để mà đánh số cho đúng trật tự bạn ạ. Bởi vì rất có thể cái block cột thứ 6 lại được insert trước thằng block cột thứ nhất ấy chứ.
2/- Khoảng cách giữa các block có được biết chính xác hay không hay phải mò từng chú một.
3/- Về vị trí đặt text cũng gặp rắc rối y như trường hợp trên bạn ạ.

Vậy nên mình thiển nghĩ thế này: Chả có tiên thì ni cô cũng xài tạm vậy, cách xài như sau
Nếu như bạn đã biết chính xác cái khoảng cách giữa các block là như nhau và biết được chính xác cái điểm chèn của block đấu tiên thì bạn hoàn toàn có thể xài cái củ lisp mà mình đã biếu bạn với chút xíu công phu như sau:
1/- Bạn gõ giùm mình ba hay bốn cái dấu ; vào trước các dòng code (command "insert" bn "r" gd p1 "" "" "") để nó trở thành ;;;;(command "insert" bn "r" gd p1 "" "" "") .
2/- Bạn load lisp và chạy nó y sì như các thao tác cũ chỉ lưu ý rằng chọn đúng cái điểm chèn đầu tiên của cái block mà bạn muốn bắt đầu đánh số và nhập đúng cái khoảng cách giữa các block đã được chèn. Vậy là khi chạy lisp nó sẽ "quên béng cái việc insert block cột của bạn mà chỉ nhăm nhăm đánh số thôi bạn ạ. Và nó cũng sẽ đánh số i sì phóoc như bạn muốn
3/- Sau khi xài xong, bạn chịu khó xóa sạch mấy cái dấu ; đi là lisp lại trở về nguyên trạng bạn ạ. Vậy là khỏi phải lo tậu thêm lisp mới cho nặng máy bạn nhé.

Hì hì, vì mình chuyên đi mót nên bày bạn cái cách hơi củ chuối này. Bạn đừng giận nếu bạn không muốn xài thế nhé. Cái cách tuy củ chuối nhưng được việc ra phết bạn ạ. Ít ra nó cũng cứu đói được cho mình nhiều phen rồi bạn ạ.

Hy vọng bạn sẽ bật cười khi xài cái cách này. Mong bạn thành công

PS: bạn nguyenkhoadung ơi, lúc nào bạn ranh rảnh chỉ mình cách xài cái lệnh ME với nhé. Mình xài cad2004 mà chả biết mò cái đó ra sao. Thấy bạn xài tới tới mà ham quá à. Thanks bạn trước nha.



cảm ơn bạn Bình nhiều, có 1 vấn đề thế này bạn ạ.sau khi tớ dùng lisp IDO của bạn thì các chữ khác của tớ nó lại bị nhảy font hết cả như thế này này ( kể cả têxt gốc cũng bị nhảy font về kiểu text này ] text gốc tớ dùng font .vnarialH tớ hi vọng text sau khi dùng lisp nó cũng như thế


http://www.mediafire...ym/Drawing1.dwg

trang up của cadviet lỗi nên đành up vào đây :cheers:. cảm ơn bạn Bình
  • 0

#1832 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 10 April 2009 - 03:55 PM

cảm ơn bạn Bình nhiều, có 1 vấn đề thế này bạn ạ.sau khi tớ dùng lisp IDO của bạn thì các chữ khác của tớ nó lại bị nhảy font hết cả như thế này này ( kể cả têxt gốc cũng bị nhảy font về kiểu text này ] text gốc tớ dùng font .vnarialH tớ hi vọng text sau khi dùng lisp nó cũng như thế
http://www.mediafire...ym/Drawing1.dwg

trang up của cadviet lỗi nên đành up vào đây :cheers:. cảm ơn bạn Bình

Hì hì,
Bạn nguyenkhoadung98 ơi, cái nè là tại bạn đấy chứ hổng phải tại lisp đâu bạn ạ. Lần trước bạn bảo mình là muốn text mới có cùng đặc tính với text gốc. Báo hại mình phải mày mò cái bộ mã DXF của text gốc. Bạn có thấy trong lisp một lô xích xông các đặc tính của text được mình moi ra không? Trong đó có cái Style của text là 03CHU_NHO. Mình mò vào cái Style này thì lại thấy font gốc là txt.shx. Vậy nên mình mới tống cái font này vào trong dòng code (command "style" .......)
bạn ạ. Khi chạy thử mình thấy cái text gốc nó bị chuyển font là hiểu ngay rằng bạn đã modify cái style gốc rồi, nhưng chịu chết chả hiểu bạn dùng font gì mà sửa nữa, đành cứ để nó đó. Bây giờ bạn muốn sửa thì chỉ cần thay cái font .vnarialH của bạn vào chỗ cái chuỗi "txt.shx" trong đoạn code nói trên là xong mà. Nhưng bạn nhớ là phải đúng tên file font cả về tên và kiểu file bạn nhé. Mình chả biết cái font của bạn có kiểu file là gì cả, bạn kiểm tra lại nhé.
Trong trường hợp bạn không muốn sửa thì chỉ đơn giản là bạn xóa béng cái dòng code này đi là xong và như vậy text mới sẽ không cùng style với text gốc cũng như các text khác trên bản vẽ sẽ chả thay đổi gì.
Chúc bạn thành công.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#1833 baodenhp

baodenhp

    biết vẽ arc

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

Đã gửi 10 April 2009 - 05:04 PM

Các bạn giúp mình lisp này với. Mình muốn ghi text lý trình của đường ( ví dụ: 1+200), điểm gốc của đường được chọn trước và nếu vuông text đó vuông góc với đường tại vị trí ghi text thi tốt quá. Cảm ơn nhiều nhiều!!!!
  • 0

#1834 conghoan1003

conghoan1003

    biết vẽ point

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

Đã gửi 10 April 2009 - 09:22 PM

Bạn nào co lisp này cho mình xin với. Mình cần ghi khoảng cách thực (nếu có tỷ lệ bản vẽ càng tốt) tại hai điểm. Đại loại là mình muốn ghi kích thước của hai điểm tại một vị trí nào đó. Ai biết giúp mình với nhé, Cảm ơn nhiều!
  • 0
Học học nữa học mãi.
Đúp học lại!

#1835 ustoichivost

ustoichivost

    biết vẽ circle

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

Đã gửi 10 April 2009 - 09:35 PM

Bạn nào co lisp này cho mình xin với. Mình cần ghi khoảng cách thực (nếu có tỷ lệ bản vẽ càng tốt) tại hai điểm. Đại loại là mình muốn ghi kích thước của hai điểm tại một vị trí nào đó. Ai biết giúp mình với nhé, Cảm ơn nhiều!

Dùng lệnh distance của Lisp, sau đó gọi lệnh mtext của cad để ghi ra vào một điểm nào đó !
  • 0

#1836 haanh

haanh

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 2875 Bài viết
Điểm đánh giá: 1554 (rất tốt)

Đã gửi 10 April 2009 - 09:35 PM

Bạn nào co lisp này cho mình xin với. Mình cần ghi khoảng cách thực (nếu có tỷ lệ bản vẽ càng tốt) tại hai điểm. Đại loại là mình muốn ghi kích thước của hai điểm tại một vị trí nào đó. Ai biết giúp mình với nhé, Cảm ơn nhiều!

Ko hiểu ý câu hỏi của bác...bản vẽ đó là do bác vẽ hay của người khác??? Tỷ lệ bản vẽ khi bác thiết lập Mvsetup là bao nhiêu???
Hay nhất bác cư úp cái bản vẽ của bác lên sẽ tiện trả lời cho bác.
  • 0

“Sống trong đời sống cần có một tấm lòng / Để làm gì em biết không ? / Để gió cuốn đi, để gió cuốn đi...”


#1837 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 11 April 2009 - 03:25 PM

Chào cả nhà!
Cho mình hỏi ai có lisp cộng (trừ) tất cả các số được chọn thêm một giá trị nào đó không? Cho mình xin với. Hiện mình đang dung lisp này, nó cũng có thể cộng được nhưng không hiểu tại sao nó lại có sai số khi sử dụng.
Thank!

Chào bạn conghoan1003,
Bạn hãy tham khảo cái hàm (mapcar...) và kết hợp với hàm (lambda...) xem bạn nhé. Các hàm này có trong Help Developer của Cad và theo thiển ý của mình nó làm được cái điều bạn muốn. Hy vọng bạn sẽ sử dụng tốt chúng cho công việc của bạn.
Chúc bạn vui.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#1838 ndtnv

ndtnv

    biết lệnh minsert

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

Đã gửi 13 April 2009 - 04:24 PM

cảm ơn bạn Bình nhiều, có 1 vấn đề thế này bạn ạ.sau khi tớ dùng lisp IDO của bạn thì các chữ khác của tớ nó lại bị nhảy font hết cả như thế này

này ( kể cả têxt gốc cũng bị nhảy font về kiểu text này ] text gốc tớ dùng font .vnarialH tớ hi vọng text sau khi dùng lisp nó cũng như thế
http://www.mediafire...ym/Drawing1.dwg

trang up của cadviet lỗi nên đành up vào đây :cheers:. cảm ơn bạn Bình

Vì không có thời gian nên tôi viết tạm lisp này cho bạn.
Hàm TachTen là hàm giả để lấy trị default, bạn có thể sửa lại theo lisp bạn có).
Nếu hoàn chỉnh thì:
-Kết quả thì các đối tượng chọn ban đầu sẽ nằm ở vị trí ban đầu chứ không phải cuối cùng, nhưng tôi nghĩ là không quan trọng.
-Cho phép chọn chiều (trong lisp này, chiều sẽ là từ điểm gốc đến đầu xa của pline
Cách dùng:
chọn đối tượng cột và text cùng lúc, chương trình sẽ nhận dạng text ( nếu có nhiều text có thể bị lỗi) và block (nếu có) để lấy điểm chèn tự động ( cột có thể nhiều đối tượng và không nhất thiết phải là block )
Điểm gốc có thể nằm ngoài đường chuẩn
Copy code vào word rồi paste
(defun GetDxf(n e) (cdr (assoc n e)))
(defun ModDxf(n v e)
(if (GetDxf n e)
(entmod (subst (cons n v) (assoc n e) e))
(entmod (append e (list (cons n v))))
)
)

(defun c:dsc ( / i k e ss plObj p0 p1 a0 a1 kc d d0 len om pre id inc pos asc las)
(defun TachTen(s)
(setq pre "T2/l1-" id 1 pos "" asc 97 las 0)
)
(defun TenCotKe()
(setq id (+ id inc))
(if asc (setq las (rem (1+ las) 3)))
(strcat pre (itoa id) pos (if asc (chr (+ asc las)) ""))
)
; Main program
(princ "\nChon doi tuong va text :")
(setq ss (ssget ) i -1)
(repeat (sslength ss)
(setq i (1+ i)e (entget (ssname ss i)) )
(if (= "INSERT" (GetDxf 0 e))
(setq p1 (GetDxf 10 e))
)
(if (= "TEXT" (GetDxf 0 e))
(progn (TachTen (GetDxf 1 e)) (setq k i) )
)
)
(setq plObj (car (entsel "\nHay chon duong polyline ")))
(if (not (and k plObj)) (quit))
(setq p0 (getpoint "\nChon diem goc de copy : "))
(if (not p0) (setq p0 p1))
(if (not (setq p0 (vlax-curve-getClosestPointTo plObj p0))) (quit))
(setq inc (getint "\nHay nhap he so tang giam <1> : "))
(if (not inc ) (setq inc 1) )
(setq d (getreal "\nChon khoang cach giua cac doi tuong: "))
(setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq a0 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p0))))
(setq d0 (vlax-curve-getDistAtPoint plObj p0))
(setq len (vlax-curve-getDistAtPoint plObj (vlax-curve-getEndPoint plObj)))
(if (< d0 (/ len 2))
(setq len (- len d0))
(setq len d0 d (- d))
)
(setq d0 (+ d0 d))
(while (setq p1 (vlax-curve-getpointatdist plObj d0))
(setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p1))))
(command "COPY" ss "" p0 p0)
(command "MOVE" "P" "" p0 p1)
(command "ROTATE" "P" "" p1 (/ (* 180 (- a1 a0)) pi))
(setq e (entget (ssname ss k)))
(ModDxf 1 (TenCotKe) e)
(setq d0 (+ d0 d) p0 p1 a0 a1)
)
(setvar "OSMODE" om)
)

  • 0

#1839 ndtnv

ndtnv

    biết lệnh minsert

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

Đã gửi 14 April 2009 - 07:19 AM

Các bạn giúp mình lisp này với. Mình muốn ghi text lý trình của đường ( ví dụ: 1+200), điểm gốc của đường được chọn trước và nếu vuông text đó vuông góc với đường tại vị trí ghi text thi tốt quá. Cảm ơn nhiều nhiều!!!!

Bạn tham khảo bài đánh số cột ngay trên, nếu không được thì hãy gửi bản vẽ mẫu và ghi rõ yêu cầu (nhớ save cad từ 2004 về trước)
  • 0

#1840 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 14 April 2009 - 07:06 PM

Vì không có thời gian nên tôi viết tạm lisp này cho bạn.
Hàm TachTen là hàm giả để lấy trị default, bạn có thể sửa lại theo lisp bạn có).
Nếu hoàn chỉnh thì:
-Kết quả thì các đối tượng chọn ban đầu sẽ nằm ở vị trí ban đầu chứ không phải cuối cùng, nhưng tôi nghĩ là không quan trọng.
-Cho phép chọn chiều (trong lisp này, chiều sẽ là từ điểm gốc đến đầu xa của pline
Cách dùng:
chọn đối tượng cột và text cùng lúc, chương trình sẽ nhận dạng text ( nếu có nhiều text có thể bị lỗi) và block (nếu có) để lấy điểm chèn tự động ( cột có thể nhiều đối tượng và không nhất thiết phải là block )
Điểm gốc có thể nằm ngoài đường chuẩn
Copy code vào word rồi paste

(defun GetDxf(n e) (cdr (assoc n e)))
(defun ModDxf(n v e)
(if (GetDxf n e)
(entmod (subst (cons n v) (assoc n e) e))
(entmod (append e (list (cons n v))))
)
)

(defun c:dsc ( / i k e ss plObj p0 p1 a0 a1 kc d d0 len om pre id inc pos asc las)
(defun TachTen(s)
(setq pre "T2/l1-" id 1 pos "" asc 97 las 0)
)
(defun TenCotKe()
(setq id (+ id inc))
(if asc (setq las (rem (1+ las) 3)))
(strcat pre (itoa id) pos (if asc (chr (+ asc las)) ""))
)
; Main program
(princ "\nChon doi tuong va text :")
(setq ss (ssget ) i -1)
(repeat (sslength ss)
(setq i (1+ i)e (entget (ssname ss i)) )
(if (= "INSERT" (GetDxf 0 e))
(setq p1 (GetDxf 10 e))
)
(if (= "TEXT" (GetDxf 0 e))
(progn (TachTen (GetDxf 1 e)) (setq k i) )
)
)
(setq plObj (car (entsel "\nHay chon duong polyline ")))
(if (not (and k plObj)) (quit))
(setq p0 (getpoint "\nChon diem goc de copy : "))
(if (not p0) (setq p0 p1))
(if (not (setq p0 (vlax-curve-getClosestPointTo plObj p0))) (quit))
(setq inc (getint "\nHay nhap he so tang giam <1> : "))
(if (not inc ) (setq inc 1) )
(setq d (getreal "\nChon khoang cach giua cac doi tuong: "))
(setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq a0 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p0))))
(setq d0 (vlax-curve-getDistAtPoint plObj p0))
(setq len (vlax-curve-getDistAtPoint plObj (vlax-curve-getEndPoint plObj)))
(if (< d0 (/ len 2))
(setq len (- len d0))
(setq len d0 d (- d))
)
(setq d0 (+ d0 d))
(while (setq p1 (vlax-curve-getpointatdist plObj d0))
(setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p1))))
(command "COPY" ss "" p0 p0)
(command "MOVE" "P" "" p0 p1)
(command "ROTATE" "P" "" p1 (/ (* 180 (- a1 a0)) pi))
(setq e (entget (ssname ss k)))
(ModDxf 1 (TenCotKe) e)
(setq d0 (+ d0 d) p0 p1 a0 a1)
)
(setvar "OSMODE" om)
)

Chào bác ndtnv,
Trong đoạn lisp trên đây của bác, bác sử dụng lệnh rotate để quay toàn bộ các đối tượng được chọn quanh điểm gốc p1 sau khi bác đã move nó về đó. Như vậy hoàn toàn có thể đảm bảo được vị trí tương đối giữa các đối tượng text và block. Tuy nhiên sẽ có trường hợp text bị lộn ngược bác ạ vì khi quay text không thể sắp lại theo ý người dùng được. Điều này cũng là điều mà mình cảm thấy bí khi phải giải quyết nó, làm sao cho text vừa không lộn ngược lại vừa đảm bảo vị trí tương đối với block. Bác có cách giải quyết nào trong trường hợp này không bác nhỉ? Hoặc giả bác gợi ý cho mình để mình thử mày mò xem sao. Cám ơn bác trước nhé.
Cái hàm lấy góc a0 và a1 của bác rất hay. Cám ơn bác đã chỉ dẫn.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.