Jump to content
InfoFile
Tác giả: Tot77
Bài viết gốc: 298162
Tên lệnh: ctt ctk dh dhh hk
Lisp tính cao độ

@phamhung12 Đã sữa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength...
>>

@phamhung12 Đã sữa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0) (setvar 'cmdecho 0)
  (setvar "BLIPMODE" 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX ))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1) )
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
       (setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )      
       (setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
       (setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)(setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
 
=========================
; Duong han cong truong net khuat
(defun C:CTK ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "OK\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n (fix ( / l a )))
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0)  (setvar 'cmdecho 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY ))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
(setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )
       (setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
       (setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
   (progn
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
)
) 
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)  (setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
(defun C:DH()
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho")) )
(setvar "cmdecho" 0)
   (setq P1 (getpoint "\nDiem dau : "))
   (setq P2 (getpoint p1 "\nDiem cuoi : "))
   (setq P3 (getpoint p1 "\nPhia co duong han : "))
   (setq  l (getreal  "\nChieu cao duong han : "))
   (setq goc (angle p1 p2))
   (setq xA (car P1))
   (setq yA (cadr P1))
   (setq xB (car P2))
   (setq yB (cadr P2))
   (setq xC (car P3))
   (setq yC (cadr P3))
   (setq dau (- (* (- xC xA) (- yB yA)) (* (- xB xA) (- yC yA))))
   (setq n (distance P1 P2))
   (setq x1 (- xA (* l (cos goc))))
   (setq y1 (- yA (* l (sin goc))))
(setvar "osmode" 0)
   (While (> n 0)
 (setq x1 (+ x1 (* l (cos goc))))
 (setq y1 (+ y1 (* l (sin goc))))
 (setq x2 (- x1 (* l (sin goc))))
 (setq y2 (+ y1 (* l (cos goc))))
 (setq x3 (+ x1 (* l (sin goc))))
 (setq y3 (- y1 (* l (cos goc))))
 (setq dau2 (- (* (- x2 xA) (- yB yA)) (* (- xB xA) (- y2 yA))))
 (if (> (* dau2 dau) 0)    
(command "line" (list x1 y1) (list x2 y2) "")
(command "line" (list x1 y1) (list x3 y3) "")
 )
 (setq n (- n l))
   );of while
(mapcar 'setvar (list "osmode" "cmdecho") om)
(command "undo" "e")
(PRINC)
); of defun
;;==============================================================================
 
=========================
;bo sung duong han net khuat
; Duong han
(defun C:DHH ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n  (fix ( / l a ) ) )
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
  (setvar "osmode" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
;;==============================================================================
 
=========================
; Duong han net khuat
(defun C:HK ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
 (command "LINE" p3 p4 "")
)  
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
 

 

@namtran : Không thấy bạn trả lời, đoán là đo khoảng cách theo phương x.

(defun C:4 (/ L te p1 p2)
(setq p1 (getpoint "\n Chon diem thu nhat :"))
(while (setq p2 (getpoint p1 "\n Chon diem thu hai :"))
(setq L (abs (- (car p1) (car p2))))
(setq te (entget (car (entsel "\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)    
(princ)
)
 

<<

Filename: 298162_ctt_ctk_dh_dhh_hk.lsp
Tác giả: Tot77
Bài viết gốc: 298184
Tên lệnh: ctt ctk dh dhh hk
[Nhờ chỉnh sửa] Lisp tính cao độ

Tôi quên test trường hợp line nằm ngang, chỉ test line xiên. Sửa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b)...
>>

Tôi quên test trường hợp line nằm ngang, chỉ test line xiên. Sửa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
  
  (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil)
le (if (equal (cos (angle p1 p2)) 1 0.001) 'sin 'cos))
  (if (equal ((eval le) (angle d c)) ((eval le) (+ 1.5708 (angle p1 p2))) 0.001) 
    (setq lenh '+) (setq lenh '-))
  
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0) (setvar 'cmdecho 0)
  (setvar "BLIPMODE" 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX ))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1) )
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
(setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )      
(setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)(setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
 
=========================
; Duong han cong truong net khuat
(defun C:CTK ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "OK\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
  (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil)
le (if (equal (cos (angle p1 p2)) 1 0.001) 'sin 'cos))
  (if (equal ((eval le) (angle d c)) ((eval le) (+ 1.5708 (angle p1 p2))) 0.001) 
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n (fix ( / l a )))
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0)  (setvar 'cmdecho 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY ))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
(setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )
       (setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
       (setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
   (progn
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
)
) 
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)  (setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
(defun C:DH()
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho")) )
(setvar "cmdecho" 0)
   (setq P1 (getpoint "\nDiem dau : "))
   (setq P2 (getpoint p1 "\nDiem cuoi : "))
   (setq P3 (getpoint p1 "\nPhia co duong han : "))
   (setq  l (getreal  "\nChieu cao duong han : "))
   (setq goc (angle p1 p2))
   (setq xA (car P1))
   (setq yA (cadr P1))
   (setq xB (car P2))
   (setq yB (cadr P2))
   (setq xC (car P3))
   (setq yC (cadr P3))
   (setq dau (- (* (- xC xA) (- yB yA)) (* (- xB xA) (- yC yA))))
   (setq n (distance P1 P2))
   (setq x1 (- xA (* l (cos goc))))
   (setq y1 (- yA (* l (sin goc))))
(setvar "osmode" 0)
   (While (> n 0)
 (setq x1 (+ x1 (* l (cos goc))))
 (setq y1 (+ y1 (* l (sin goc))))
 (setq x2 (- x1 (* l (sin goc))))
 (setq y2 (+ y1 (* l (cos goc))))
 (setq x3 (+ x1 (* l (sin goc))))
 (setq y3 (- y1 (* l (cos goc))))
 (setq dau2 (- (* (- x2 xA) (- yB yA)) (* (- xB xA) (- y2 yA))))
 (if (> (* dau2 dau) 0)    
(command "line" (list x1 y1) (list x2 y2) "")
(command "line" (list x1 y1) (list x3 y3) "")
 )
 (setq n (- n l))
   );of while
(mapcar 'setvar (list "osmode" "cmdecho") om)
(command "undo" "e")
(PRINC)
); of defun
;;==============================================================================
 
=========================
;bo sung duong han net khuat
; Duong han
(defun C:DHH ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
  (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil)
le (if (equal (cos (angle p1 p2)) 1 0.001) 'sin 'cos))
  (if (equal ((eval le) (angle d c)) ((eval le) (+ 1.5708 (angle p1 p2))) 0.001) 
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n  (fix ( / l a ) ) )
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
  (setvar "osmode" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
;;==============================================================================
 
=========================
; Duong han net khuat
(defun C:HK ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
  (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil)
le (if (equal (cos (angle p1 p2)) 1 0.001) 'sin 'cos))
  (if (equal ((eval le) (angle d c)) ((eval le) (+ 1.5708 (angle p1 p2))) 0.001) 
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
 (command "LINE" p3 p4 "")
)  
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
 
 

<<

Filename: 298184_ctt_ctk_dh_dhh_hk.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 298201
Tên lệnh: ha
lisp chuyển region sang pline!!

Woa! Thử lại cái này chắc ổn rồi.

; Doan Van Ha - CadViet.com - Ngay 14/6/2014
; Lisp: chuyen cac doi tuong thanh Region, sao do chuyen qua Pline.
(defun C:HA( / ssnho sslon ss i ent objArr)
 (vl-load-com) (setq cmd (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "undo" "be")
 (setq ssnho (ssget "_X" '((0 . "REGION"))))
 (princ "\nChon cac doi tuong muon chuyen thanh Region...")
 (command...
>>

Woa! Thử lại cái này chắc ổn rồi.

; Doan Van Ha - CadViet.com - Ngay 14/6/2014
; Lisp: chuyen cac doi tuong thanh Region, sao do chuyen qua Pline.
(defun C:HA( / ssnho sslon ss i ent objArr)
 (vl-load-com) (setq cmd (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "undo" "be")
 (setq ssnho (ssget "_X" '((0 . "REGION"))))
 (princ "\nChon cac doi tuong muon chuyen thanh Region...")
 (command "region" (ssget '((0 . "ARC,*LINE"))) "")
 (setq sslon (ssget "_X" '((0 . "REGION"))))
 (if ssnho
  (repeat (setq i (sslength ssnho))
   (ssdel (ssname ssnho (setq i (1- i))) sslon)))
 (while (setq ent (ssname sslon 0))
  (setq ss (ssadd)
        obj (vlax-ename->vla-object ent)
        objArr (vlax-safearray->list (vlax-variant-value (vla-Explode obj))))
  (foreach memb objArr
   (setq ss (ssadd (vlax-vla-object->ename memb) ss)))
  (command "_.PEDIT" (ssname ss 0) "_YES" "_JOIN" ss "" "")
  (ssdel ent sslon))
 (setvar 'cmdecho cmd) (command "undo" "e") 
 (princ))
 


<<

Filename: 298201_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 298179
Tên lệnh: ha
Nhờ viết lisp tính diện tích ...

cái lisp e post là lisp tính diện tích theo kiểu pick vào vùng cần tính diện tích và tính được diện tích của nhiều vùng 1 lúc( ví dụ pick vào giữa hình vuông, và pick vào giữa hình tròn chẳng hạn thì nó sẽ tính diện tích cả 2 hình cộng lại) giả sử ta được diện tích 2 hình đó là 100, sau đó chọn text để nó...

>>

cái lisp e post là lisp tính diện tích theo kiểu pick vào vùng cần tính diện tích và tính được diện tích của nhiều vùng 1 lúc( ví dụ pick vào giữa hình vuông, và pick vào giữa hình tròn chẳng hạn thì nó sẽ tính diện tích cả 2 hình cộng lại) giả sử ta được diện tích 2 hình đó là 100, sau đó chọn text để nó ghi kết quả 100 ra thay cho text có sẵn.

bây h e nhờ bác sửa hộ cái đoạn cuối, sau khi tính được diện tích 100 rồi, khi pick vào text có sẵn để điền kết quả , giả sử text đang có giá trị là 300 thì nó sẽ lấy 300 trừ đi 100 và ghi kết quả là 200.

Như lisp "ha" của bác viết lần trước thì nó đã lấy 300 - 100 rồi nhưng mà cách tính diện tích thì lại chọn đường bao hình vuông và chỉ chọn được 1 hình.

Hề hề hề,

Mạn phép bác DoanVanHa sửa lại cái lisp của bác , nhưng không biết có đúng ý chủ thớt không nữa.

(defun C:HA( / ent1 ent2 dt1 dt2 obj2)
 (setq ss (ssadd))
 (setq dt1 0)
 (while (setq pt1 (getpoint "\n Pick diem ben trong vung kin can tinh dien tich"))
         (command "-boundary" pt1 "")
         (setq ent1 (entlast))
         (ssadd ent1 ss)
         (setq dt1 (+ dt1 (vla-get-Area (vlax-ename->vla-object ent1))))
 )
 (setq ent2 (car (entsel "\nChon text can hieu chinh gia tri: ")))
 (setq dt2 (atof (vla-get-textstring (setq obj2 (vlax-ename->vla-object ent2)))))
 (vla-put-textstring obj2 (rtos (- dt2 dt1) 2)) 
 (command "erase" ss "")
)

<<

Filename: 298179_ha.lsp
Tác giả: Tot77
Bài viết gốc: 298162
Tên lệnh: 4
Lisp tính cao độ

@phamhung12 Đã sữa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength...
>>

@phamhung12 Đã sữa lại.

;;;Ve duong han
=========================
;;CHUONG TRINH HAN THEP
; Duong han cong truong thuong
(defun C:CTT ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0) (setvar 'cmdecho 0)
  (setvar "BLIPMODE" 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX ))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1) )
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
       (setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )      
       (setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
       (setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)(setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
 
=========================
; Duong han cong truong net khuat
(defun C:CTK ( / )
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "OK\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
; Chieu cao duong han lay mac dinh bang 0,75 khoang cach
  (if (= b nil) (setq b (* 0.75 a)))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n (fix ( / l a )))
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
; Luu bien he thong
  (setq osmodeold (getvar "osmode")) 
  (setq blipmodeold (getvar "blipmode")) 
; Undo phai de truoc lenh chinh bien he thong
  (command "_UNDO" "_GROUP")
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0)  (setvar 'cmdecho 0) 
; Them mot vong lap cho i
  (while (<= i n )
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY ))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + ( + x1 (* -1 (* b (/ deltaY l) ) ) ) (* b (/ deltaX l)))) 
;;; (setq y2 ( + (+ y1 (* b (/ deltaX l) ) ) (* b (/ deltaY l))))
;;; (setq p4 (list x2 y2))
;;; (setq x5 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y5 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p5 (list x5 y5))
(setq x6 ( + x1  (* b (/ deltaX l)))) 
(setq y6 ( + y1 (* b (/ deltaY l)))) 
(setq p6 (list x6 y6) )
       (setq p5 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
       (setq p4 (polar p6 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
   (progn
(command "LINE" p3 p4 "")
(command "LINE" p5 p6 "")
)
) 
(setq i (+ i 1))
  )
  (command "_UNDO" "_END")
; Khoi phuc lai cac bien he thong da thay doi
  (setvar "BLIPMODE" blipmodeold) 
  (setvar "OSMODE" osmodeold)  (setvar 'cmdecho 1)
  (princ)
)
;;==============================================================================
(defun C:DH()
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho")) )
(setvar "cmdecho" 0)
   (setq P1 (getpoint "\nDiem dau : "))
   (setq P2 (getpoint p1 "\nDiem cuoi : "))
   (setq P3 (getpoint p1 "\nPhia co duong han : "))
   (setq  l (getreal  "\nChieu cao duong han : "))
   (setq goc (angle p1 p2))
   (setq xA (car P1))
   (setq yA (cadr P1))
   (setq xB (car P2))
   (setq yB (cadr P2))
   (setq xC (car P3))
   (setq yC (cadr P3))
   (setq dau (- (* (- xC xA) (- yB yA)) (* (- xB xA) (- yC yA))))
   (setq n (distance P1 P2))
   (setq x1 (- xA (* l (cos goc))))
   (setq y1 (- yA (* l (sin goc))))
(setvar "osmode" 0)
   (While (> n 0)
 (setq x1 (+ x1 (* l (cos goc))))
 (setq y1 (+ y1 (* l (sin goc))))
 (setq x2 (- x1 (* l (sin goc))))
 (setq y2 (+ y1 (* l (cos goc))))
 (setq x3 (+ x1 (* l (sin goc))))
 (setq y3 (- y1 (* l (cos goc))))
 (setq dau2 (- (* (- x2 xA) (- yB yA)) (* (- xB xA) (- y2 yA))))
 (if (> (* dau2 dau) 0)    
(command "line" (list x1 y1) (list x2 y2) "")
(command "line" (list x1 y1) (list x3 y3) "")
 )
 (setq n (- n l))
   );of while
(mapcar 'setvar (list "osmode" "cmdecho") om)
(command "undo" "e")
(PRINC)
); of defun
;;==============================================================================
 
=========================
;bo sung duong han net khuat
; Duong han
(defun C:DHH ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2))
  (setq n  (fix ( / l a ) ) )
  (setq deltaX (- (car p2) (car p1)))
  (setq deltaY (- (cadr p2) (cadr p1)))
  (setq i 0)
  (setvar "osmode" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(command "LINE" p3 p4 "")
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
;;==============================================================================
 
=========================
; Duong han net khuat
(defun C:HK ( / )
(command "undo" "be")
(setq om (mapcar 'getvar (list "osmode" "cmdecho" "BLIPMODE")))
(setvar "cmdecho" 0)
  (setq p1 (getpoint "\nStart point : ") )
  (setq p2 (getpoint p1 "Ok\nEnd point   : ") )
  (if (null a) (setq a 1.0))
  (setq _a (getdist (strcat "Ok\nDistance <" (rtos a 2 1) ">: ")))
  (if (/= _a nil) (setq a _a))
  (if (null b) (setq b 1.0))
  (setq _b (getdist (strcat "Ok\nLength <" (rtos b 2 1) ">: ")))
  (if (/= _b nil) (setq b _b))
           (setq c (getpoint (strcat "\nPick Side: "))
d (inters p1 p2 c (polar c (+ 1.5708 (angle p1 p2)) 1) nil))
           (if (equal (cos (angle d c)) (cos (+ 1.5708 (angle p1 p2))) 0.001)
    (setq lenh '+) (setq lenh '-))
  (setq l  (distance p1 p2) )
  (setq n  (fix ( / l a ) ) )
  (setq deltaX ( - (car p2) (car p1) ) )
  (setq deltaY ( - (cadr p2) (cadr p1) ) )
  (setq i 0)
  (setvar "OSMODE" 0)
  (setvar "BLIPMODE" 0) 
  ;(command "_UNDO" "_GROUP");
  (while (<= i n)
(setq x1 ( + (car p1) (* i (* (/ a l) deltaX))))
(setq y1 ( + (cadr p1) (* i (* ( / a l ) deltaY))))
(setq p3 (list x1 y1))
;;; (setq x2 ( + x1 (* -1 (* b (/ deltaY l))))) 
;;; (setq y2 ( + y1 (* b (/ deltaX l)))) 
;;; (setq p4 (list x2 y2))
       (setq p4 (polar p3 ((eval lenh) (angle p1 p2) 1.5708) b))
(if (< (rem i 6) 4) 
 (command "LINE" p3 p4 "")
)  
(setq i (+ i 1))
  )
 (mapcar 'setvar (list "osmode" "cmdecho" "BLIPMODE") om)
(command "undo" "e")
  (princ)
)
 

 

@namtran : Không thấy bạn trả lời, đoán là đo khoảng cách theo phương x.

(defun C:4 (/ L te p1 p2)
(setq p1 (getpoint "\n Chon diem thu nhat :"))
(while (setq p2 (getpoint p1 "\n Chon diem thu hai :"))
(setq L (abs (- (car p1) (car p2))))
(setq te (entget (car (entsel "\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)    
(princ)
)
 

<<

Filename: 298162_4.lsp
Tác giả: Tot77
Bài viết gốc: 297707
Tên lệnh: tmp
lisp polyline

Của bạn đây. Chú ý:

1. File ket qua.xls phải có trong cùng thư mục với file cad, và file đó phải đóng khi chạy lisp. Vì muốn test cho nên tôi chỉ ghi kết quả ở bên cạnh chứ không đè lên dữ liệu cũ.

2. Lisp dựa vào toạ độ điểm chèn block cột, cho nên nếu toạ độ đó sai thì kết quả sẽ sai.

3. Trong lisp có liên quan đến 1 số layer  : "DZ0.4kV XDMoi" , "cot" . Do đó nếu không...

>>

Của bạn đây. Chú ý:

1. File ket qua.xls phải có trong cùng thư mục với file cad, và file đó phải đóng khi chạy lisp. Vì muốn test cho nên tôi chỉ ghi kết quả ở bên cạnh chứ không đè lên dữ liệu cũ.

2. Lisp dựa vào toạ độ điểm chèn block cột, cho nên nếu toạ độ đó sai thì kết quả sẽ sai.

3. Trong lisp có liên quan đến 1 số layer  : "DZ0.4kV XDMoi" , "cot" . Do đó nếu không có các layer đó thì sẽ bị lỗi.

4. Khi chạy lisp thấy hơi lâu là do load excel, nhanh chậm tuỳ theo cấu hình máy.

Tôi chỉ mới test trên file bạn đưa, bạn test thêm nhiều file khác, có phát sinh lỗi gì thì cho tôi biết.

(defun c:tmp()
(vl-load-com)
(defun dxf(id v) (cdr (assoc id (entget v))))
(defun midp(a b) (polar a (angle a b) (* 0.5 (distance a b))))  
(defun ang(pt1 pt2) (if (< (car pt1) (car pt2)) (angle pt1 pt2) (angle pt2 pt1)))
(defun timtxt(pt)
(cadar (vl-sort ssc '(lambda(x y) (< (distance (car x) pt) (distance (car y) pt))))))
(defun timcdr(a) (caar (vl-remove-if '(lambda(x) (/= (cadr x) a)) ssc)))
 
(defun tgoc(a b c / d e f g)
(setq d (inters a b c (polar c (+ (angle a b) 1.5708) 1) nil))    
(setq e (abs (- (angle b c) (angle a b))))    
(if (> e pi) (setq e (- (* 2 pi) e)))
(strcat (angtos e 1 4)
(if (equal (cos (angle d c)) (cos (+ 1.5708 (angle a b))) 0.001) "T" "P"))
)
 
(defun txtmake1(pt1 pt2 txt / tm)
(entmake (list '(0 . "TEXT") '(8 . "Cot")
(cons 10 (setq tm (polar (midp pt1 pt2) (+ 1.5708 (ang pt1 pt2)) 3))) '(40 . 3.0) (cons 1 txt)
(cons 50  (ang pt1 pt2)) '(41 . 0.8) '(7 . "Vu") '(71 . 0) '(72 . 1) (cons 11 tm) '(73 . 2)))
)
 
(defun txtmake2(pt1 pt2 txt / tm)
(entmake (list '(0 . "TEXT") '(8 . "loaiday") '(62 . 90)
(cons 10 (setq tm (polar pt2 (angle pt1 pt2) 3))) '(40 . 1.0) (cons 11 tm)
(cons 1 (strcat "L" (chr (car (reverse (vl-string->list txt)))) "=" (substr txt 1 (1- (strlen txt)))))
(cons 50 (angle pt1 pt2)) '(41 . 0.8) '(7 . "Vu") '(71 . 0) '(72 . 0) '(73 . 2)))
) 
 
;;========================;;
 
(command "undo" "be")
(prompt "\nChon Block cot, Text cot va Line:")
(setq ssx (acet-ss-to-list (ssget '((0 . "INSERT,TEXT,LINE"))))
sst (vl-remove-if-not '(lambda(x) (and (= "TEXT" (dxf 0 x)) (= (dxf 8 x) "Cot") (/= 0 (atoi (dxf 1 x))))) ssx)
ssi (vl-remove-if-not '(lambda(x) (= "INSERT" (dxf 0 x))) ssx)
ssl (vl-remove-if-not '(lambda(x) (and (= "LINE" (dxf 0 x)) (= (dxf 8 x) "DZ0.4kV XDMoi"))) ssx)
ssc (vl-sort (mapcar '(lambda(x) (setq tt10 (dxf 10 x)) (list (dxf 10 (car
(vl-sort ssi '(lambda(y z) (< (distance tt10 (dxf 10 y))
(distance tt10 (dxf 10 z))))))) (dxf 1 x))) sst)
'(lambda(y z) (< (atoi (cadr y)) (atoi (cadr z)))))
ssj (vl-sort (mapcar '(lambda(x) (list (timtxt (dxf 10 x)) (timtxt (dxf 11 x)))) ssl)
'(lambda(y z) (< (atoi (car y)) (atoi (car z)))))
ssj (mapcar '(lambda(x) (if (setq tm (vl-remove-if-not '(lambda(y)
(equal pi (abs (- pi (abs (- (angle (car y) (timcdr (last x)))
(angle (timcdr (car x)) (car y)))))) 0.001)) ssc))
(cons (car x) (append (mapcar 'last tm) (list (last x)))) x)) ssj)   
)  
(setq excel (vlax-create-object "Excel.Application")  
currworkbook (vlax-invoke-method (vlax-get-property excel 'Workbooks) 'Open (strcat (getvar 'dwgprefix) "Ket qua.xls"))
cells (vlax-get-property (vlax-get-property excel 'ActiveSheet) 'Cells)
row 6
col 4)
 
(setq n -1 n1 0)
(repeat (1- (length ssc))
(setq v1 (nth (setq n (1+ n)) ssc)
v2 (nth (1+ n) ssc))
(vlax-put-property cells 'Item row col (last v1))
(if (= n (- (length ssc) 2)) (vlax-put-property cells 'Item (1+ row) col (last v2)))
 
(if (setq tm (vl-remove-if-not '(lambda(x) (and (member (last v1) x) (member (last v2) x))) ssj))  
(progn
(txtmake1 (car v1) (car v2) (setq tm1 (rtos (distance (car v1) (car v2)) 2 0)))
(vlax-put-property cells 'Item (1+ row) (1+ col) tm1)
 
(if (and (setq tm2 (vl-remove-if-not '(lambda(x) (and (member (last v1) x)
(> (vl-position (last v1) x) 0))) ssj))
(< 3 (atoi (setq goc (tgoc (timcdr (nth (1- (vl-position (last v1) (car tm2))) (car tm2)))
(car v1) (car v2))))))
(progn
(txtmake2 (timcdr (nth (1- (vl-position (last v1) (car tm2))) (car tm2))) (car v1) goc)
(if (< (atoi goc) 90)
(vlax-put-property cells 'Item row (+ 2 col)
(strcat "G" (itoa (setq n1 (1+ n1))) "=" goc)))))
)
)
(setq row (1+ row))
)
 
(vlax-invoke-method currworkbook 'Save)
(vlax-invoke-method excel 'Quit)
(command "undo" "e")
(princ)
)

<<

Filename: 297707_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 298643
Tên lệnh: tmp
Giúp mk List vẽ điểm biết khoảng cách và góc

Bạn thử cái này. Nó có hỏi thêm phía so với AB. Khi nhập góc nhớ có thêm chữ "d".

 

(defun c:tmp()
  (setq a (getpoint "\nChon diem A:")
b (getpoint a "\nChon diem B:")
g (angtof (getstring "\nNhap goc<thi du: 10d20'30\">:") 3)
kc (getreal "\nNhap khoang cach:")
p (getpoint "\nNhap phia cua diem can ve so voi AB:")
p1 (inters a b p (polar p (+ 1.5708 (angle a b)) 1) nil)
c (polar b (if (equal (angle p1 p) (+...
>>

Bạn thử cái này. Nó có hỏi thêm phía so với AB. Khi nhập góc nhớ có thêm chữ "d".

 

(defun c:tmp()
  (setq a (getpoint "\nChon diem A:")
b (getpoint a "\nChon diem B:")
g (angtof (getstring "\nNhap goc<thi du: 10d20'30\">:") 3)
kc (getreal "\nNhap khoang cach:")
p (getpoint "\nNhap phia cua diem can ve so voi AB:")
p1 (inters a b p (polar p (+ 1.5708 (angle a b)) 1) nil)
c (polar b (if (equal (angle p1 p) (+ 1.5708 (angle a b)) 0.001)
    (- (+ pi (angle a b)) g) (+ (- (angle a b) pi ) g)) kc))
  
  (command "line" b c "")
)

 

P/S: Bạn viết yêu cầu bằng tiếng gì lạ vậy?


<<

Filename: 298643_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 298612
Tên lệnh: brk
Nhờ viết lisp chia Line hoặc Polyline thành nhiều đoạn Polyline

Bạn thử cái này xem. 

(defun c:brk(/ ent os)
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (command "undo" "be") 
  (setq ent (car (entsel "\nChon Line/Polyline bi cat:"))
os (getvar...
>>

Bạn thử cái này xem. 

(defun c:brk(/ ent os)
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (command "undo" "be") 
  (setq ent (car (entsel "\nChon Line/Polyline bi cat:"))
os (getvar 'osmode))
  (setvar 'osmode 0)
  (prompt "\nChon cac Line/Polyline de cat:")
  (mapcar '(lambda(x) (mapcar '(lambda(y) (command "break" ent y y)) (ints ent x)))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (command "undo" "e") (setvar 'osmode os)
)

<<

Filename: 298612_brk.lsp
Tác giả: duy782006
Bài viết gốc: 297832
Tên lệnh: themtext bottext
Hỏi cách thêm kí tự bất kỳ vào text
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null...
>>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:THEMTEXT (/ c e ss txt cmde ttdangs ttdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null ttdangs)(setq ttdangs ""))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
                 (setq txt (strcat ttdangt (cdr (assoc 1 e)) ttdangs))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

(defun c:BOTTEXT (/ c e ss txt cmde tbdangs tbdangt)
  (command "undo" "be")
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq tbdangt (getreal "\nSo ky tu muon bot phia truoc:")) 
  (setq tbdangs (getreal "\nSo ky tu muon bot phia sau:")) 
  (if (null tbdangt)(setq tbdangt 0))
  (if (null tbdangs)(setq tbdangs 0))
  (setq sotru (+ tbdangt tbdangs))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
(setq sochu (strlen (cdr (assoc 1 e))))
(if (> sochu sotru)
(progn
(setq txt (substr (cdr (assoc 1 e)) (fix (+ 1 tbdangt)) (fix (- sochu tbdangt tbdangs))))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
)
)

        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
   (command "undo" "end")
      (Prin1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Lệnh là  THEMTEXT và  BOTTEXT


<<

Filename: 297832_themtext_bottext.lsp
Tác giả: Tot77
Bài viết gốc: 298722
Tên lệnh: tmp
Nhờ viết lisp chia Line hoặc Polyline thành nhiều đoạn Polyline

Vậy bạn dùng thử cái này. Polyline có 2 loại nặng và nhẹ, của bạn là loại nặng, cho nên phải chuyển sang nhẹ mới dễ làm.

(defun c:tmp()
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l...
>>

Vậy bạn dùng thử cái này. Polyline có 2 loại nặng và nhẹ, của bạn là loại nặng, cho nên phải chuyển sang nhẹ mới dễ làm.

(defun c:tmp()
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (defun themdinh (v pt / entg li ptl entg1 )    
    (vla-addVertex (setq obj (vlax-ename->vla-object v))
       (1+  (fix (setq ptp (vlax-curve-getparamatpoint obj (vlax-curve-getClosestPointTo obj pt)))))
        (vlax-make-variant
            (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 1))
                    (list (car (vlax-curve-getpointatparam obj ptp)) (cadr (vlax-curve-getpointatparam obj ptp)))
            )
        )
    )
  )
  ;;;
  (command "undo" "be") 
  (setq ent (car (entsel "\nChon Line/Polyline bi cat:"))
os (getvar 'osmode))
  (if (= (cdr (assoc 0 (entget ent))) "POLYLINE")
    (progn (command "convertpoly" "L" ent "")))
  
  (setvar 'osmode 0)
  (prompt "\nChon cac Line/Polyline de cat:")
  (mapcar '(lambda(x) (mapcar '(lambda(y) (themdinh ent y)) (ints ent x)))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (command "undo" "e") (setvar 'osmode os)
)

<<

Filename: 298722_tmp.lsp
Tác giả: BKTen
Bài viết gốc: 291209
Tên lệnh: tdt
lips tính diện tích

; (rtos dtl 2 2)  Bạn thay số 2 cuối của tất cả các dòng thành số 3  cụ thể là: ;(rtos dtl 2 3)
; Hoặc Coppy đoạn code trên lưu thành file *.lsp
; chuong trinh tinh dien tich

(defun DXF (code elist)
  (cdr (assoc code elist))
);dxf

(defun c:tdt(/ dtl dtcon pt1 pt2 ss et oslast vsize)
  (if (= tl nil) (progn
    (setq tl (getreal "\n Ti le ban ve (don vi ban ve la m thi nhap ti le la 1000): "));khong can nhap...
>>

; (rtos dtl 2 2)  Bạn thay số 2 cuối của tất cả các dòng thành số 3  cụ thể là: ;(rtos dtl 2 3)
; Hoặc Coppy đoạn code trên lưu thành file *.lsp
; chuong trinh tinh dien tich

(defun DXF (code elist)
  (cdr (assoc code elist))
);dxf

(defun c:tdt(/ dtl dtcon pt1 pt2 ss et oslast vsize)
  (if (= tl nil) (progn
    (setq tl (getreal "\n Ti le ban ve (don vi ban ve la m thi nhap ti le la 1000): "));khong can nhap cung duoc
    (if tl null (setq tl 1000))
;    (setq ntl (/ 1000 tl))
;    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
   (setq ntl (/ 1000 tl))
   (setq tl2 (* ntl ntl))

  (print)
  (print)
  (setq pt1 (getpoint "\nchon diem bat ki trong hinh: "))
  (while (/= pt1 nil)
    (command "-boundary" pt1 "")
    (setq et (entlast))
    (ssadd et ss)
    (command "area" "e" "last")
    (setq vsize ( /(getvar "VIEWSIZE") 5))
    (command "hatch" "ANSI31" vsize "0" "last" "")
    (setq et (entlast))
    (ssadd et ss)
    (setq dtcon (/ (getvar "AREA") tl2))
    (setq dtl (+ dtcon dtl))
    (prompt (strcat "\ntong dien tich hinh ban chon : " (rtos dtcon 2 3)))
    (print)
    (print)
    (setq pt1 (getpoint "\nChon tiep hinh nao nua khong?: "))
  )
  (command "setvar" "OSMODE" oslast)
  (command "erase" ss "")
  (setq ss nil)
  (command "redraw")
;  (setq dtl (/ (/ dtl tl2) 2))
;  (setq dtl (/ dtl 2))
  (print)
  (prompt (strcat "\ntong dien tich cac hinh ban da chon : " (rtos dtl 2 3)))
  (print)
  (setq pt2 (getpoint "\nDiem dat dien tich: "))
  (if (/= 0 (DXF 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
    (command "text" pt2  "0" (rtos dtl 2 3))
    (command "text" pt2 "0.4" "0" (rtos dtl 2 3))
  );if
  (princ)
);defun dt
;------------------------------------------------------------------------

<<

Filename: 291209_tdt.lsp
Tác giả: Tot77
Bài viết gốc: 298794
Tên lệnh: tmp
Nhờ viết lisp chia Line hoặc Polyline thành nhiều đoạn Polyline

Bạn dùng cái này. Chỉ dùng với pline không đoạn cong.

(defun c:tmp()
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (defun themdinh (v pt / entg li ptl entg1 )    
   ...
>>

Bạn dùng cái này. Chỉ dùng với pline không đoạn cong.

(defun c:tmp()
  (vl-load-com)
  (defun ints (o1 o2 / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) acExtendBoth)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (defun themdinh (v pt / entg li ptl entg1 )    
    (vla-addVertex (setq obj (vlax-ename->vla-object v))
       (1+  (fix (setq ptp (vlax-curve-getparamatpoint obj (vlax-curve-getClosestPointTo obj pt)))))
        (vlax-make-variant
            (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 1))
                    (list (car (vlax-curve-getpointatparam obj ptp)) (cadr (vlax-curve-getpointatparam obj ptp)))
            )
        )
    )
  )
  ;;;
  (command "undo" "be") 
  (setq ent (car (entsel "\nChon Line/Polyline bi cat:")))
  (cond ((= (cdr (assoc 0 (entget ent))) "POLYLINE") (command "convertpoly" "L" ent ""))
((= (cdr (assoc 0 (entget ent))) "LINE") (command "pedit" ent "y" "" "") (setq ent (entlast))))
 
  (prompt "\nChon cac Line/Polyline de cat:")
  (mapcar '(lambda(x) (mapcar '(lambda(y) (themdinh ent y)) (ints ent x)))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (command "undo" "e") (princ)
)

<<

Filename: 298794_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 296501
Tên lệnh: tmp
Cao độ của đường LWPOLYLINE

Bạn dùng dxf code 38 để biết cao độ của pline.

(defun c:tmp()
  (mapcar '(lambda(x) (entmake (list '(0 . "TEXT")
(cons 10 (setq tm (vlax-curve-getstartPoint (vlax-ename->vla-object x))))
(cons 11 tm) (cons 1 (rtos (cdr (assoc 38 (entget x))))) (cons 40 (getvar 'textsize)))))
(acet-ss-to-list (ssget)))
)

Filename: 296501_tmp.lsp
Tác giả: duongsatdn
Bài viết gốc: 12991
Tên lệnh: test2
Sách Lập trình VBA bằng tiếng Việt
Tôi ở Đà Nẵng và chưa thấy sách này trên các cửa hàng sách!

Filename: 12991_test2.lsp
Tác giả: Tot77
Bài viết gốc: 299035
Tên lệnh: tmp
Nhờ viết lisp chia Line hoặc Polyline thành nhiều đoạn Polyline

Bạn dùng cái này thử, cho phép chọn nhiều đường bị cắt 1 lúc.

Trong hình bạn đưa là dạng Heavy polyline, cad cũ hay xài. Bây giờ cad xài loại LWPolyline. Cả 2 đều là 2DPolyline nhưng cấu trúc khác nhau. 

(defun c:tmp(/ ss)
  (vl-load-com)
  (defun ints (o1 o2 mode / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2)...
>>

Bạn dùng cái này thử, cho phép chọn nhiều đường bị cắt 1 lúc.

Trong hình bạn đưa là dạng Heavy polyline, cad cũ hay xài. Bây giờ cad xài loại LWPolyline. Cả 2 đều là 2DPolyline nhưng cấu trúc khác nhau. 

(defun c:tmp(/ ss)
  (vl-load-com)
  (defun ints (o1 o2 mode / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) mode)
 l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
   l (cdddr l)))
    l0
  )
  (defun themdinh (v pt / obj ptp)    
    (vla-addVertex (setq obj (vlax-ename->vla-object v))
       (1+  (fix (setq ptp (vlax-curve-getparamatpoint obj (vlax-curve-getClosestPointTo obj pt)))))
        (vlax-make-variant
            (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 1))
                    (list (car (vlax-curve-getpointatparam obj ptp)) (cadr (vlax-curve-getpointatparam obj ptp)))
            )
        )
    )
  )
  ;;;
  (command "undo" "be")
  (prompt "\nChon Line/Polyline bi cat:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (mapcar '(lambda(x) (cond ((= (cdr (assoc 0 (entget x))) "POLYLINE") (command "convertpoly" "L" x ""))
   ((= (cdr (assoc 0 (entget x))) "LINE") (command "pedit" x "y" "" "") (setq ss (subst (entlast) x ss))))) ss)
  (prompt "\nChon cac Line/Polyline de cat:")
  (mapcar '(lambda(x)
    (mapcar '(lambda(y)
      (mapcar '(lambda(z) (themdinh y z)) (ints x y acExtendBoth)))  ss))
 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (command "undo" "e") (princ)
)

<<

Filename: 299035_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 299257
Tên lệnh: laysty
thắc mắc về DXF

Bạn dùng lisp này.

 
(defun C:LaySty(/ file)  
    (setq file (open "LayerStyle.csv" "w"))
    (write-line "sep=," file)
    (write-line "Layer Name,Color,Linetype,Lineweight,PlotStyleName,Description" file)  
    (vlax-for item (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
       (write-line 
(apply 'strcat (mapcar '(lambda(x) (strcat (vl-princ-to-string
      ((eval (read (strcat "vla-get-"...
>>

Bạn dùng lisp này.

 
(defun C:LaySty(/ file)  
    (setq file (open "LayerStyle.csv" "w"))
    (write-line "sep=," file)
    (write-line "Layer Name,Color,Linetype,Lineweight,PlotStyleName,Description" file)  
    (vlax-for item (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
       (write-line 
(apply 'strcat (mapcar '(lambda(x) (strcat (vl-princ-to-string
      ((eval (read (strcat "vla-get-" (vl-princ-to-string x)))) item)) ","))
      (list 'Name 'Color 'Linetype 'Lineweight 'PlotStyleName 'Description))) file)
    )
    (write-line "\n" file) 
    (write-line "TextStyle Name,FontFile,BigFontFile,Height,Width,ObliqueAngle" file)
    (vlax-for item (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object)))
      (write-line
(apply 'strcat (mapcar '(lambda(x) (strcat (vl-princ-to-string
      ((eval (read (strcat "vla-get-" (vl-princ-to-string x)))) item)) ","))
      (list 'Name 'FontFile 'BigFontFile 'Height 'Width 'ObliqueAngle))) file)      
    )
    (close file)
)

<<

Filename: 299257_laysty.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 299272
Tên lệnh: ha
sửa lisp lựa chọn đầu arrow của leader

Tôi viết riêng chứ không khoái gộp chung. Lisp thay đổi ArrowheadSize của Dimension/Leader.

(defun C:HA( / txt arr)
 (princ "\nChon cac Dim/Leader can thay doi kich thuoc Arrow...")
 (ssget (list (cons 0 "LEADER,DIMENSION")))
 (initget "0.25 0.5 1 2 K")
 (setq txt (getkword "\nChon kich thuoc Arrow : "))
 (if (= txt "K")
  (setq arr (getreal "\nNhap kich thuoc Arrow: "))
 ...
>>

Tôi viết riêng chứ không khoái gộp chung. Lisp thay đổi ArrowheadSize của Dimension/Leader.

(defun C:HA( / txt arr)
 (princ "\nChon cac Dim/Leader can thay doi kich thuoc Arrow...")
 (ssget (list (cons 0 "LEADER,DIMENSION")))
 (initget "0.25 0.5 1 2 K")
 (setq txt (getkword "\nChon kich thuoc Arrow : "))
 (if (= txt "K")
  (setq arr (getreal "\nNhap kich thuoc Arrow: "))
  (setq arr (atof txt)))
 (vlax-for obj (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-put-ArrowheadSize obj arr)))
 


<<

Filename: 299272_ha.lsp
Tác giả: Tot77
Bài viết gốc: 299273
Tên lệnh: tmp
Nhờ viết lisp chia Line hoặc Polyline thành nhiều đoạn Polyline

File của bạn đụng vấn đề về ucs, tôi sửa lại lisp để dùng với mọi ucs.

(defun c:tmp(/ ss)
  (vl-load-com)
  (defun ints (o1 o2 mo / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) mo)
l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
 l (cdddr l)))
    l0
  )
 
  (defun themdinh (v pt / obj ptp)  ...
>>

File của bạn đụng vấn đề về ucs, tôi sửa lại lisp để dùng với mọi ucs.

(defun c:tmp(/ ss)
  (vl-load-com)
  (defun ints (o1 o2 mo / l0 l)
    (setq l (vlax-Invoke (vlax-EName->vla-Object o1) "IntersectWith" (vlax-EName->vla-Object o2) mo)
l0 nil)
    (while l
      (setq l0 (append l0 (list (list (car l) (cadr l) (caddr l))))
 l (cdddr l)))
    l0
  )
 
  (defun themdinh (v pt / obj ptp)    
    (vla-addVertex (setq obj (vlax-ename->vla-object v))
       (1+ (fix (setq ptp (vlax-curve-getparamatpoint obj (vlax-curve-getClosestPointTo obj pt)))))
        (vlax-make-variant
            (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 1))
                    (list (car  (trans (vlax-curve-getpointatparam obj ptp) 0 v))
 (cadr (trans (vlax-curve-getpointatparam obj ptp) 0 v)))))
    )  
  )
  ;;;
  (command "undo" "be")
  (prompt "\nChon Line/Polyline bi cat:")
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (mapcar '(lambda(x) (cond ((= (cdr (assoc 0 (entget x))) "POLYLINE") (command "convertpoly" "L" x ""))
   ((= (cdr (assoc 0 (entget x))) "LINE") (command "pedit" x "y" "") (setq ss (subst (entlast) x ss))))) ss)
  (prompt "\nChon cac Line/Polyline de cat:")
  (mapcar '(lambda(x)
    (mapcar '(lambda(y)
      (mapcar '(lambda(z) (themdinh y z)) (ints x y acExtendBoth))) ss))
 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE,*POLYLINE")))))))
  (command "undo" "e") (princ)
)

<<

Filename: 299273_tmp.lsp
Tác giả: phamhung12
Bài viết gốc: 299419
Tên lệnh: cua
Lisp cửa đi

Mình có tìm được 1 lisp vẽ cửa đi D1 = 1 cánh, D2 = 2 cánh

Cách dùng : 1/ Chọn điểm 1 là điểm góc của tường, Pick diem 2 là bắt đầu vẽ cửa

2/ Pick diem 3 là diểm vuông góc với cạnh 1&2 nằm trên cạnh tường // cạnh 1&2 cũng là hướng cửa

3/ Bề rộng cửa --> Vẽ

Nhờ bác Tot77 hoặc các bác nào giỏi Lisp phát triển thêm loại cửa D4 = 4 cánh giúp mình với....

>>

Mình có tìm được 1 lisp vẽ cửa đi D1 = 1 cánh, D2 = 2 cánh

Cách dùng : 1/ Chọn điểm 1 là điểm góc của tường, Pick diem 2 là bắt đầu vẽ cửa

2/ Pick diem 3 là diểm vuông góc với cạnh 1&2 nằm trên cạnh tường // cạnh 1&2 cũng là hướng cửa

3/ Bề rộng cửa --> Vẽ

Nhờ bác Tot77 hoặc các bác nào giỏi Lisp phát triển thêm loại cửa D4 = 4 cánh giúp mình với. Thanks!

;;Chuong trinh ve cua di
;(alert "checkpoint0")
(setq oldosmode (getvar "osmode")
ORTHO (getvar "ORTHOMODE"))
(defun D1 () 
       (command ".line" p2 (polar p3 ang2 r) "" ".line" p4 p5 "")
       (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (< (cadr p2) (cadr p3))
               ) 
               (and (> (cadr p1) (cadr p2)) 
                    (> (car p2) (car p3))
               )
               (and (< (cadr p1) (cadr p2)) 
                    (< (car p2) (car p3))
               )
           )
           (setq ang 90)
           (setq ang -90)
       ) ; end of if

       (command ".arc"  "C" p3 (polar p3 ang2 r) "A" ang "")
      
); END OF D1
;(alert "checkpoint1")
(defun D2 ()
       (command ".line" p2 (polar p3 ang2 (/ r 2)) ""
                ".line" p5 (polar p4 ang2 (/ r 2)) ""
       )
        (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (< (cadr p2) (cadr p3))
               ) 
               (and (> (cadr p1) (cadr p2)) 
                    (> (car p2) (car p3))
               )
               (and (< (cadr p1) (cadr p2)) 
                    (< (car p2) (car p3))
               )
           )
           (setq ang 90)
           (setq ang -90)
       ) ; end of if
       (command ".arc"  "C" p3 (polar p3 ang2 (/ r 2)) "A" ang "")
       (setq m (ssget "L"))
       (command ".mirror" m "" (polar p2 ang1 (/ r 2)) (polar p3 ang1 (/ r 2)) "")
) ;End of D2

; Than chuong trinh chinh
(defun c:cua (/ p1 p2 p3 p4 p5 p23 p45 r res i ang)
(command "undo" "be")
       (initget "D1 D2")
       (setq res (getkword "\D1 1CANH _ D2 2CANH ? <D1>:"))

; Nhap so lieu 
       (setvar "osmode" 33)
       (setq p1 ( getpoint "\nDIEM THU 1, GOC TUONG:"))
       (setvar "osmode" 512 )
       (setvar "ORTHOMODE" 1)
       (setq p2 ( getpoint p1 "\nDIEM THU 2:"))    
       (setvar "lastpoint" p2)
       (setvar "osmode" 128)
 ;(alert "checkpoint6")          
       (setq p3 ( getpoint p2 "DIEM THU 3:")
             ang1 (angle p1 p2)
             ang2 (angle p2 p3)
             r (getreal "\nBe rong cua:")
             p4 (polar p3 ang1 r)
             p5 (polar p2 ang1 r)
             p23 (polar p2 ang2 (/ (distance p2 p3) 2))
             p45 (polar p5 ang2 (/ (distance p5 p4) 2))
       )
       (setvar "osmode" 0)
       (command ".break" p2 p5 
                ".break" p3 p4)
       (if (= res "D1") (D1))
       (if (= res "D2") (D2))
       (setvar "osmode" oldosmode)
(SETVAR "ORTHOMODE" ORTHO) 
(command "undo" "e")
   (princ)     
); end of programmer

 


<<

Filename: 299419_cua.lsp
Tác giả: Tot77
Bài viết gốc: 299459
Tên lệnh: cua
Lisp cửa đi

Bạn thử cái này.

 

 
(setq oldosmode (getvar "osmode")
      ORTHO (getvar "ORTHOMODE"))
(defun D1 () 
       (command ".line" p2 (polar p3 ang2 r) "")
       (command ".line" p4 p5 "")
       (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (<...
>>

Bạn thử cái này.

 

 
(setq oldosmode (getvar "osmode")
      ORTHO (getvar "ORTHOMODE"))
(defun D1 () 
       (command ".line" p2 (polar p3 ang2 r) "")
       (command ".line" p4 p5 "")
       (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (< (cadr p2) (cadr p3))
               ) 
               (and (> (cadr p1) (cadr p2)) 
                    (> (car p2) (car p3))
               )
               (and (< (cadr p1) (cadr p2)) 
                    (< (car p2) (car p3))
               )
           )
           (setq ang 90)
           (setq ang -90)
       ) ; end of if
 
       (command ".arc"  "C" p3 (polar p3 ang2 r) "A" ang "")
      
); END OF D1
;(alert "checkpoint1")
(defun D2 ()
       (command ".line" p2 (polar p3 ang2 (/ r 2)) ""
                ".line" p5 (polar p4 ang2 (/ r 2)) ""
       )
        (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (< (cadr p2) (cadr p3))
               ) 
               (and (> (cadr p1) (cadr p2)) 
                    (> (car p2) (car p3))
               )
               (and (< (cadr p1) (cadr p2)) 
                    (< (car p2) (car p3))
               )
           )
           (setq ang 90)
           (setq ang -90)
       ) ; end of if
       (command ".arc"  "C" p3 (polar p3 ang2 (/ r 2)) "A" ang "")
       (setq m (ssget "L"))
       (command ".mirror" m "" (polar p2 ang1 (/ r 2)) (polar p3 ang1 (/ r 2)) "")
) ;End of D2
 
(defun D4 ()
       (setq ss0 (ssadd))
       (command ".line" p2 (polar p3 ang2 (/ r 4)) "")
       (ssadd (entlast) ss0)
        (if (or (and (> (car p2) (car p1)) 
                    (> (cadr p2) (cadr p3))
               ) 
               (and (< (car p2) (car p1)) 
                    (< (cadr p2) (cadr p3))
               ) 
               (and (> (cadr p1) (cadr p2)) 
                    (> (car p2) (car p3))
               )
               (and (< (cadr p1) (cadr p2)) 
                    (< (car p2) (car p3))
               )
           )
           (setq ang 90)
           (setq ang -90)
       ) ; end of if
       (command ".arc"  "C" p3 (polar p3 ang2 (/ r 4)) "A" ang "")
       (ssadd (entlast) ss0)
       (command ".line" (setq tm (polar p3 ang1 (/ r 4))) (polar tm ang2 (/ r 4)) "")
       (ssadd (entlast) ss0)
       (command ".arc"  "C" tm (polar tm ang2 (/ r 4)) "A" ang "")
       (ssadd (entlast) ss0)      
  
       (command ".mirror" ss0 "" (polar p2 ang1 (/ r 2)) (polar p3 ang1 (/ r 2)) "")
)
 
; Than chuong trinh chinh
(defun c:cua (/ )
(command "undo" "be")
       (initget "D1 D2 D4")
       (setq res (getkword "\D1 1CANH _ D2 2CANH _ D4 4CANH ? <D1>:"))
       (if (not res) (setq res "D1"))
; Nhap so lieu 
       (setvar "osmode" 33)
       (setq p1 ( getpoint "\nDIEM THU 1, GOC TUONG:"))
       (setvar "osmode" 512 )
       (setvar "ORTHOMODE" 1)
       (setq p2 ( getpoint p1 "\nDIEM THU 2:"))    
       (setvar "lastpoint" p2)
       (setvar "osmode" 128)
 ;(alert "checkpoint6")          
       (setq p3 ( getpoint p2 "DIEM THU 3:")
             ang1 (angle p1 p2)
             ang2 (angle p2 p3)
             r (getreal "\nBe rong cua:")
             p4 (polar p3 ang1 r)
             p5 (polar p2 ang1 r)
             p23 (polar p2 ang2 (/ (distance p2 p3) 2))
             p45 (polar p5 ang2 (/ (distance p5 p4) 2))
       )
       (setvar "osmode" 0)
       (command ".break" p2 p5 
                ".break" p3 p4)
       (if (= res "D1") (D1))
       (if (= res "D2") (D2))
       (if (= res "D4") (D4))
       (setvar "osmode" oldosmode)
(SETVAR "ORTHOMODE" ORTHO) 
(command "undo" "e")
   (princ)     
); end of programmer
 

 

 

Có lisper chắc phải có csharper và vbaper chứ hả?  :)  :)


<<

Filename: 299459_cua.lsp

Trang 162/301

162