Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Người theo dõi 0
ssg

Tiện ích nhỏ về kích thước và đo đạc

Bởi ssg , trong AutoLisp

Các bài được khuyến nghị

ssg    1.102

ssg
Đã đăng

1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure:

 

;;;=================================
;;;SMALL UTILITIES FOR DIMENSIONS AND MEASUREMENTS
;;;CAC TIEN ICH NHO VE KICH THUOC VA DO LUONG
;;;=================================
;;;HUONG DAN:
;;;SaveAs *.lsp, go lenh Appload, go cac lenh sau day de chay:
;;;-------------------------------------------------------------
;;;1- Lenh SCC: SCale with Constant dimensions
;;;Hoat dong nhu lenh Scale cua AutoCAD nhung giu nguyen gia tri Dim
;;;(chi co "Dim Scale Linear" va "Dim Scale Overall" thay doi)
;;;Cac thuoc tinh khac cua Dim khong bi anh huong
;;;Tuy chon Dim Scale Overall = Y cho phep scale ca cac yeu to khac cua Dim
;;;(text, kich thuoc mui ten, khoang nho ra cua duong giong...)
;;;Mac dinh la Dim Scale Overall = N
;;;Chap nhan cac Dim co DimStyle khac nhau
;;;-------------------------------------------------------------
;;;2- Lenh CHD: CHeck Dimensions
;;;Kiem tra toan bo cac doi tuong Dimensions co trong ban ve
;;;Dim bi edit bang Text Override se chuyen sang layer DimCheck co mau RED
;;;-------------------------------------------------------------
;;;3- Lenh XY: ghi toa do X, Y cua diem pick
;;;Ket qua ghi dang Leader va 1 Mtext co 2 dong
;;;-------------------------------------------------------------
;;;4- Lenh CL: ve Center Line cho duong tron tai layer CEN
;;;Neu Layer khong ton tai, chuong trinh tu tao layer CEN
;;;Voi thiet lap mau Magenta, Ltype ACAD_ISO04W100
;;;-------------------------------------------------------------
;;;5- Lenh L1: Do va ghi chieu dai 1 doi tuong, vi tri dat text do user chon
;;;-------------------------------------------------------------
;;;6- Lenh LL: Do va ghi chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Vi tri dat text tai diem giua cua tung doi tuong
;;;-------------------------------------------------------------
;;;7- Lenh LTO: Do va ghi tong chieu dai nhieu doi tuong, user chon vi tri dat text
;;;-------------------------------------------------------------
;;;GHI CHU CHUNG VOI KET QUA GHI DANG TEXT
;;;Chuong trinh dung TextStyle hien hanh de ghi ket qua
;;;So chu so thap phan phu thuoc thiet lap Units
;;;Vao Format -> Units -> chon Precision tuy y
;;;-------------------------------------------------------------
;;;Copyright by ssg - www.cadviet.com - March 2009
;;;=================================



;;;PUBLIC FUNCTIONS
;;;=================================
(defun getL(e) ;;;Get Length of curve e
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;-------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
   h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
   (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss) 
   (setq
       e (ssname ss i)
       Le (append Le (list e))
       i (1+ i)
   )
)
Le
)
;;;-------------------------------------------------------------
(Defun Bdraw()
;;;Begin draw, get some current system variables, disable them
(setq OldOs (getvar "osmode"))
(setq OldLay (getvar "clayer"))
(setvar "osmode" 0)
)
;;;-------------------------------------------------------------
(Defun Edraw()
;;;End draw, reset all system variables
(setvar "osmode" OldOs)
(setvar "clayer" OldLay)
)
;;;-------------------------------------------------------------
(Defun SetLayer(MyLayer)
;;;Make and Set Layer 
(if (not (tblsearch "LAYER" MyLayer)) (progn
(Cond
((= (strcase MyLayer) "0") (setq MyColor "White" MyLtype "Continuous"))
((= (strcase MyLayer) "CEN") (setq MyColor "Magenta" MyLtype "ACAD_ISO04W100"))
((= (strcase MyLayer) "DIM") (setq MyColor "Green" MyLtype "Continuous"))
((= (strcase MyLayer) "HATCH") (setq MyColor "Yellow" MyLtype "Continuous"))
((= (strcase MyLayer) "HID") (setq MyColor "Cyan" MyLtype "ACAD_ISO02W100"))
((= (strcase MyLayer) "STT") (setq MyColor 140 MyLtype "Continuous"))
((= (strcase MyLayer) "KHUNGTEN") (setq MyColor 120 MyLtype "Continuous"))
)
(Command "Layer" "N" MyLayer "L" MyLtype MyLayer "C" MyColor MyLayer "T" MyLayer "")
))
(setvar "CLayer" MyLayer)
)
;;;=================================



;;;DIMENSION AND GEOMETRIC COMMAND FUNCTIONS
;;;=================================
(defun SCDim( / e ob OName SF LSF)
(while (setq e (ssname ssd 0))
 (setq
   ob (vlax-ename->vla-object e)
   OName (vla-get-ObjectName ob)
   SF (vla-get-ScaleFactor ob)
 )
 (if (not (wcmatch OName "*AngularDimension"))
   (progn
     (setq LSF (vla-get-LinearScaleFactor ob))
     (command "dimoverride" "dimlfac" (/ LSF k) "" e "")
   )
 )
 (if (/= opt "N") (command "dimoverride" "dimscale" (* SF k) "" e ""))
 (ssdel e ssd)
)
)
;;;-------------------------------------------------------------
(defun C:SCC( / ss ssd p k opt) ;;;SCale with Constant dimensions
(vl-load-com)
(setq
 ss (ssget)
 ssd (ssget "p" '((0 . "DIMENSION")))
 p (getpoint "\nBase point:")
 k (getreal "\nScale Factor:")
 opt (strcase (getstring "\nDim scale overall? [Yes/No] :"))
)
(if (= opt "") (setq opt "N"))
(if (> k 1)
 (progn (command "scale" ss "" p k) (SCDim))
 (progn (SCDim) (command "scale" ss "" p k))
)
(princ)
)
;;;=================================
(defun C:CHD( / ss e txt n) ;;;CHeck Dimensions
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch "layer" "DimCheck"))
 (command "Layer" "N" "DimCheck" "C" "Red" "DimCheck" "")
)
(while (setq e (ssname ss 0))
 (setq txt (cdr (assoc 1 (entget e))))
 (if (not (or (= txt "") (vl-string-search "<>" txt))) (progn
   (command "change" e "" "p" "LA" "DimCheck" "")
   (setq n (1+ n))
 ))
 (ssdel e ss)
)
(if (= n 0) (setq S "Ket qua check: OK")
 (setq S (strcat "Co " (itoa n) " Dimensions bi sua Text Override"
          "\nDa duoc chuyen sang layer DimCheck co mau RED!")
 )
)
(alert S)
(princ)
)
;;;=================================
(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X=" (rtos (car p1)) "\\PY=" (rtos (cadr p1))) "")
(princ)
)
;;;=================================
(defun C:CL(/ p r p1 p2 p3 p4 oldos oldlay) ;;;Center Line duong tron
(setq
   p (getpoint "\nCenter point:")
   oldOrtho (getvar "orthomode")
)
(setvar "orthomode" 1)
(setq r (getdist p "\nEnd point: "))
(Bdraw)
(SetLayer "CEN")
(command "line" (polar p pi r) (polar p 0 r) "")
(command "line" (polar p (/ pi 2) r) (polar p (/ pi -2) r) "")
(setvar "orthomode" oldOrtho)
(Edraw)
(princ)
)
;;;=================================
(defun C:L1( / e L) ;;;Do va ghi chieu dai 1 doi tuong
(setq  e (car (entsel "\nSelect object:")))
(command "lengthen" e "")
(setq L (getvar "perimeter"))
(wtxt (strcat "L= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================
(defun Measure1(e / L p)
(vl-load-com)
(setq
   L (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
   p (vlax-curve-getPointAtDist e (/ L 2)) 
)
(wtxt (strcat "L= " (rtos L)) p)
)
;;;-------------------------------------------------------------
(defun C:LL( / ss e) ;;;Do chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Ket qua ghi tai diem giua cua tung doi tuong
(setq ss (ssget '((0 . "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))))
(while (setq e (ssname ss 0))
   (measure1 e)
   (ssdel e ss)
)
)
;;;=================================
(defun C:LTO( / ss Le L e L1) ;;;Do va ghi tong chieu dai nhieu doi tuong
(setq
   ss (ssget '((0 . "LINE,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")))
   Le (ss2ent ss)
   L 0
)
(foreach e Le (setq L (+ L (getL e))))
(wtxt (strcat "Lt= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================

 

2- Có vấn đề gì về sử dụng, các bạn phản hồi để ssg sửa

 

3- Cần bổ sung thêm những tiện ích gì thuộc dạng này không?

  • Vote tăng 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

buiquangnam    17

buiquangnam
Đã đăng (Đă chỉnh sửa)
1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure:

 

;;;=================================
;;;SMALL UTILITIES FOR DIMENSIONS AND MEASUREMENTS
;;;CAC TIEN ICH NHO VE KICH THUOC VA DO LUONG
;;;=================================
;;;HUONG DAN:
;;;SaveAs *.lsp, go lenh Appload, go cac lenh sau day de chay:
;;;-------------------------------------------------------------
;;;1- Lenh SCC: SCale with Constant dimensions
;;;Hoat dong nhu lenh Scale cua AutoCAD nhung giu nguyen gia tri Dim
;;;(chi co "Dim Scale Linear" va "Dim Scale Overall" thay doi)
;;;Cac thuoc tinh khac cua Dim khong bi anh huong
;;;Tuy chon Dim Scale Overall = Y cho phep scale ca cac yeu to khac cua Dim
;;;(text, kich thuoc mui ten, khoang nho ra cua duong giong...)
;;;Mac dinh la Dim Scale Overall = N
;;;Chap nhan cac Dim co DimStyle khac nhau
;;;-------------------------------------------------------------
;;;2- Lenh CHD: CHeck Dimensions
;;;Kiem tra toan bo cac doi tuong Dimensions co trong ban ve
;;;Dim bi edit bang Text Override se chuyen sang layer DimCheck co mau RED
;;;-------------------------------------------------------------
;;;3- Lenh XY: ghi toa do X, Y cua diem pick
;;;Ket qua ghi dang Leader va 1 Mtext co 2 dong
;;;-------------------------------------------------------------
;;;4- Lenh CL: ve Center Line cho duong tron tai layer CEN
;;;Neu Layer khong ton tai, chuong trinh tu tao layer CEN
;;;Voi thiet lap mau Magenta, Ltype ACAD_ISO04W100
;;;-------------------------------------------------------------
;;;5- Lenh L1: Do va ghi chieu dai 1 doi tuong, vi tri dat text do user chon
;;;-------------------------------------------------------------
;;;6- Lenh LL: Do va ghi chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Vi tri dat text tai diem giua cua tung doi tuong
;;;-------------------------------------------------------------
;;;7- Lenh LTO: Do va ghi tong chieu dai nhieu doi tuong, user chon vi tri dat text
;;;-------------------------------------------------------------
;;;GHI CHU CHUNG VOI KET QUA GHI DANG TEXT
;;;Chuong trinh dung TextStyle hien hanh de ghi ket qua
;;;So chu so thap phan phu thuoc thiet lap Units
;;;Vao Format -> Units -> chon Precision tuy y
;;;-------------------------------------------------------------
;;;Copyright by ssg - www.cadviet.com - March 2009
;;;=================================
;;;PUBLIC FUNCTIONS
;;;=================================
(defun getL(e) ;;;Get Length of curve e
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;-------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
   h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
   (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss) 
   (setq
       e (ssname ss i)
       Le (append Le (list e))
       i (1+ i)
   )
)
Le
)
;;;-------------------------------------------------------------
(Defun Bdraw()
;;;Begin draw, get some current system variables, disable them
(setq OldOs (getvar "osmode"))
(setq OldLay (getvar "clayer"))
(setvar "osmode" 0)
)
;;;-------------------------------------------------------------
(Defun Edraw()
;;;End draw, reset all system variables
(setvar "osmode" OldOs)
(setvar "clayer" OldLay)
)
;;;-------------------------------------------------------------
(Defun SetLayer(MyLayer)
;;;Make and Set Layer 
(if (not (tblsearch "LAYER" MyLayer)) (progn
(Cond
((= (strcase MyLayer) "0") (setq MyColor "White" MyLtype "Continuous"))
((= (strcase MyLayer) "CEN") (setq MyColor "Magenta" MyLtype "ACAD_ISO04W100"))
((= (strcase MyLayer) "DIM") (setq MyColor "Green" MyLtype "Continuous"))
((= (strcase MyLayer) "HATCH") (setq MyColor "Yellow" MyLtype "Continuous"))
((= (strcase MyLayer) "HID") (setq MyColor "Cyan" MyLtype "ACAD_ISO02W100"))
((= (strcase MyLayer) "STT") (setq MyColor 140 MyLtype "Continuous"))
((= (strcase MyLayer) "KHUNGTEN") (setq MyColor 120 MyLtype "Continuous"))
)
(Command "Layer" "N" MyLayer "L" MyLtype MyLayer "C" MyColor MyLayer "T" MyLayer "")
))
(setvar "CLayer" MyLayer)
)
;;;=================================
;;;DIMENSION AND GEOMETRIC COMMAND FUNCTIONS
;;;=================================
(defun SCDim( / e ob OName SF LSF)
(while (setq e (ssname ssd 0))
 (setq
   ob (vlax-ename->vla-object e)
   OName (vla-get-ObjectName ob)
   SF (vla-get-ScaleFactor ob)
 )
 (if (not (wcmatch OName "*AngularDimension"))
   (progn
     (setq LSF (vla-get-LinearScaleFactor ob))
     (command "dimoverride" "dimlfac" (/ LSF k) "" e "")
   )
 )
 (if (/= opt "N") (command "dimoverride" "dimscale" (* SF k) "" e ""))
 (ssdel e ssd)
)
)
;;;-------------------------------------------------------------
(defun C:SCC( / ss ssd p k opt) ;;;SCale with Constant dimensions
(vl-load-com)
(setq
 ss (ssget)
 ssd (ssget "p" '((0 . "DIMENSION")))
 p (getpoint "\nBase point:")
 k (getreal "\nScale Factor:")
 opt (strcase (getstring "\nDim scale overall? [Yes/No] :"))
)
(if (= opt "") (setq opt "N"))
(if (> k 1)
 (progn (command "scale" ss "" p k) (SCDim))
 (progn (SCDim) (command "scale" ss "" p k))
)
(princ)
)
;;;=================================
(defun C:CHD( / ss e txt n) ;;;CHeck Dimensions
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch "layer" "DimCheck"))
 (command "Layer" "N" "DimCheck" "C" "Red" "DimCheck" "")
)
(while (setq e (ssname ss 0))
 (setq txt (cdr (assoc 1 (entget e))))
 (if (not (or (= txt "") (vl-string-search "<>" txt))) (progn
   (command "change" e "" "p" "LA" "DimCheck" "")
   (setq n (1+ n))
 ))
 (ssdel e ss)
)
(if (= n 0) (setq S "Ket qua check: OK")
 (setq S (strcat "Co " (itoa n) " Dimensions bi sua Text Override"
          "\nDa duoc chuyen sang layer DimCheck co mau RED!")
 )
)
(alert S)
(princ)
)
;;;=================================
(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X=" (rtos (car p1)) "\\PY=" (rtos (cadr p1))) "")
(princ)
)
;;;=================================
(defun C:CL(/ p r p1 p2 p3 p4 oldos oldlay) ;;;Center Line duong tron
(setq
   p (getpoint "\nCenter point:")
   oldOrtho (getvar "orthomode")
)
(setvar "orthomode" 1)
(setq r (getdist p "\nEnd point: "))
(Bdraw)
(SetLayer "CEN")
(command "line" (polar p pi r) (polar p 0 r) "")
(command "line" (polar p (/ pi 2) r) (polar p (/ pi -2) r) "")
(setvar "orthomode" oldOrtho)
(Edraw)
(princ)
)
;;;=================================
(defun C:L1( / e L) ;;;Do va ghi chieu dai 1 doi tuong
(setq  e (car (entsel "\nSelect object:")))
(command "lengthen" e "")
(setq L (getvar "perimeter"))
(wtxt (strcat "L= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================
(defun Measure1(e / L p)
(vl-load-com)
(setq
   L (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
   p (vlax-curve-getPointAtDist e (/ L 2)) 
)
(wtxt (strcat "L= " (rtos L)) p)
)
;;;-------------------------------------------------------------
(defun C:LL( / ss e) ;;;Do chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Ket qua ghi tai diem giua cua tung doi tuong
(setq ss (ssget '((0 . "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))))
(while (setq e (ssname ss 0))
   (measure1 e)
   (ssdel e ss)
)
)
;;;=================================
(defun C:LTO( / ss Le L e L1) ;;;Do va ghi tong chieu dai nhieu doi tuong
(setq
   ss (ssget '((0 . "LINE,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")))
   Le (ss2ent ss)
   L 0
)
(foreach e Le (setq L (+ L (getL e))))
(wtxt (strcat "Lt= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================

 

2- Có vấn đề gì về sử dụng, các bạn phản hồi để ssg sửa

 

3- Cần bổ sung thêm những tiện ích gì thuộc dạng này không?

 

Thanks.

bạn có thể nói rõ thêm về các ứng dụng cũng như cách sử dụng(câu lệnh) được kô?

Chỉnh sửa theo ssg
Sửa 1 dòng chú giải

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

ssg    1.102

ssg
Đã đăng
Thanks.

bạn có thể nói rõ thêm về các ứng dụng cũng như cách sử dụng(câu lệnh) được kô?

Ssg nghĩ rằng các dòng hướng dẫn ở đầu chương trình đã đủ rồi. Tiếng Việt không dấu nhưng chắc không đến nỗi tối nghĩa! Chưa rõ lắm thì cứ chạy thử sẽ rõ.

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

ui_troi_2005    5

ui_troi_2005
Đã đăng
1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure:

 

;;;=================================
;;;SMALL UTILITIES FOR DIMENSIONS AND MEASUREMENTS
;;;CAC TIEN ICH NHO VE KICH THUOC VA DO LUONG
;;;=================================
;;;HUONG DAN:
;;;SaveAs *.lsp, go lenh Appload, go cac lenh sau day de chay:
;;;-------------------------------------------------------------
;;;1- Lenh SCC: SCale with Constant dimensions
;;;Hoat dong nhu lenh Scale cua AutoCAD nhung giu nguyen gia tri Dim
;;;(chi co "Dim Scale Linear" va "Dim Scale Overall" thay doi)
;;;Cac thuoc tinh khac cua Dim khong bi anh huong
;;;Tuy chon Dim Scale Overall = Y cho phep scale ca cac yeu to khac cua Dim
;;;(text, kich thuoc mui ten, khoang nho ra cua duong giong...)
;;;Mac dinh la Dim Scale Overall = N
;;;Chap nhan cac Dim co DimStyle khac nhau
;;;-------------------------------------------------------------
;;;2- Lenh CHD: CHeck Dimensions
;;;Kiem tra toan bo cac doi tuong Dimensions co trong ban ve
;;;Dim bi edit bang Text Override se chuyen sang layer DimCheck co mau RED
;;;-------------------------------------------------------------
;;;3- Lenh XY: ghi toa do X, Y cua diem pick
;;;Ket qua ghi dang Leader va 1 Mtext co 2 dong
;;;-------------------------------------------------------------
;;;4- Lenh CL: ve Center Line cho duong tron tai layer CEN
;;;Neu Layer khong ton tai, chuong trinh tu tao layer CEN
;;;Voi thiet lap mau Magenta, Ltype ACAD_ISO04W100
;;;-------------------------------------------------------------
;;;5- Lenh L1: Do va ghi chieu dai 1 doi tuong, vi tri dat text do user chon
;;;-------------------------------------------------------------
;;;6- Lenh LL: Do va ghi chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Vi tri dat text tai diem giua cua tung doi tuong
;;;-------------------------------------------------------------
;;;7- Lenh LTO: Do va ghi tong chieu dai nhieu doi tuong, user chon vi tri dat text
;;;-------------------------------------------------------------
;;;GHI CHU CHUNG VOI KET QUA GHI DANG TEXT
;;;Chuong trinh dung TextStyle hien hanh de ghi ket qua
;;;So chu so thap phan phu thuoc thiet lap Units
;;;Vao Format -> Units -> chon Precision tuy y
;;;-------------------------------------------------------------
;;;Copyright by ssg - www.cadviet.com - March 2009
;;;=================================
;;;PUBLIC FUNCTIONS
;;;=================================
(defun getL(e) ;;;Get Length of curve e
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;-------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
   h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
   (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss) 
   (setq
       e (ssname ss i)
       Le (append Le (list e))
       i (1+ i)
   )
)
Le
)
;;;-------------------------------------------------------------
(Defun Bdraw()
;;;Begin draw, get some current system variables, disable them
(setq OldOs (getvar "osmode"))
(setq OldLay (getvar "clayer"))
(setvar "osmode" 0)
)
;;;-------------------------------------------------------------
(Defun Edraw()
;;;End draw, reset all system variables
(setvar "osmode" OldOs)
(setvar "clayer" OldLay)
)
;;;-------------------------------------------------------------
(Defun SetLayer(MyLayer)
;;;Make and Set Layer 
(if (not (tblsearch "LAYER" MyLayer)) (progn
(Cond
((= (strcase MyLayer) "0") (setq MyColor "White" MyLtype "Continuous"))
((= (strcase MyLayer) "CEN") (setq MyColor "Magenta" MyLtype "ACAD_ISO04W100"))
((= (strcase MyLayer) "DIM") (setq MyColor "Green" MyLtype "Continuous"))
((= (strcase MyLayer) "HATCH") (setq MyColor "Yellow" MyLtype "Continuous"))
((= (strcase MyLayer) "HID") (setq MyColor "Cyan" MyLtype "ACAD_ISO02W100"))
((= (strcase MyLayer) "STT") (setq MyColor 140 MyLtype "Continuous"))
((= (strcase MyLayer) "KHUNGTEN") (setq MyColor 120 MyLtype "Continuous"))
)
(Command "Layer" "N" MyLayer "L" MyLtype MyLayer "C" MyColor MyLayer "T" MyLayer "")
))
(setvar "CLayer" MyLayer)
)
;;;=================================
;;;DIMENSION AND GEOMETRIC COMMAND FUNCTIONS
;;;=================================
(defun SCDim( / e ob OName SF LSF)
(while (setq e (ssname ssd 0))
 (setq
   ob (vlax-ename->vla-object e)
   OName (vla-get-ObjectName ob)
   SF (vla-get-ScaleFactor ob)
 )
 (if (not (wcmatch OName "*AngularDimension"))
   (progn
     (setq LSF (vla-get-LinearScaleFactor ob))
     (command "dimoverride" "dimlfac" (/ LSF k) "" e "")
   )
 )
 (if (/= opt "N") (command "dimoverride" "dimscale" (* SF k) "" e ""))
 (ssdel e ssd)
)
)
;;;-------------------------------------------------------------
(defun C:SCC( / ss ssd p k opt) ;;;SCale with Constant dimensions
(vl-load-com)
(setq
 ss (ssget)
 ssd (ssget "p" '((0 . "DIMENSION")))
 p (getpoint "\nBase point:")
 k (getreal "\nScale Factor:")
 opt (strcase (getstring "\nDim scale overall? [Yes/No] :"))
)
(if (= opt "") (setq opt "N"))
(if (> k 1)
 (progn (command "scale" ss "" p k) (SCDim))
 (progn (SCDim) (command "scale" ss "" p k))
)
(princ)
)
;;;=================================
(defun C:CHD( / ss e txt n) ;;;CHeck Dimensions
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch "layer" "DimCheck"))
 (command "Layer" "N" "DimCheck" "C" "Red" "DimCheck" "")
)
(while (setq e (ssname ss 0))
 (setq txt (cdr (assoc 1 (entget e))))
 (if (not (or (= txt "") (vl-string-search "<>" txt))) (progn
   (command "change" e "" "p" "LA" "DimCheck" "")
   (setq n (1+ n))
 ))
 (ssdel e ss)
)
(if (= n 0) (setq S "Ket qua check: OK")
 (setq S (strcat "Co " (itoa n) " Dimensions bi sua Text Override"
          "\nDa duoc chuyen sang layer DimCheck co mau RED!")
 )
)
(alert S)
(princ)
)
;;;=================================
(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(setvar "dimtad" 1)
(command "leader" p1 p2 "a" (strcat "X=" (rtos (car p1)) "\\PY=" (rtos (cadr p1))) "")
(princ)
)
;;;=================================
(defun C:CL(/ p r p1 p2 p3 p4 oldos oldlay) ;;;Center Line duong tron
(setq
   p (getpoint "\nCenter point:")
   oldOrtho (getvar "orthomode")
)
(setvar "orthomode" 1)
(setq r (getdist p "\nEnd point: "))
(Bdraw)
(SetLayer "CEN")
(command "line" (polar p pi r) (polar p 0 r) "")
(command "line" (polar p (/ pi 2) r) (polar p (/ pi -2) r) "")
(setvar "orthomode" oldOrtho)
(Edraw)
(princ)
)
;;;=================================
(defun C:L1( / e L) ;;;Do va ghi chieu dai 1 doi tuong
(setq  e (car (entsel "\nSelect object:")))
(command "lengthen" e "")
(setq L (getvar "perimeter"))
(wtxt (strcat "L= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================
(defun Measure1(e / L p)
(vl-load-com)
(setq
   L (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
   p (vlax-curve-getPointAtDist e (/ L 2)) 
)
(wtxt (strcat "L= " (rtos L)) p)
)
;;;-------------------------------------------------------------
(defun C:LL( / ss e) ;;;Do chieu dai nhieu doi tuong, cho phep chon hang loat
;;;Ket qua ghi tai diem giua cua tung doi tuong
(setq ss (ssget '((0 . "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE"))))
(while (setq e (ssname ss 0))
   (measure1 e)
   (ssdel e ss)
)
)
;;;=================================
(defun C:LTO( / ss Le L e L1) ;;;Do va ghi tong chieu dai nhieu doi tuong
(setq
   ss (ssget '((0 . "LINE,LWPOLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")))
   Le (ss2ent ss)
   L 0
)
(foreach e Le (setq L (+ L (getL e))))
(wtxt (strcat "Lt= " (rtos L)) (getpoint "\nPosition of text:"))
)
;;;=================================

 

2- Có vấn đề gì về sử dụng, các bạn phản hồi để ssg sửa

 

3- Cần bổ sung thêm những tiện ích gì thuộc dạng này không?

 

Chào bác SSQ.

 

các lisp bác đưa lên thật tuyệt vời, em cảm ơn bác nhiều lắm.

nhưng em có một thắc mắc nhỏ là cái lệnh LTO đó nó luông luôn tính tổng ở tỉ lệ 1:1, nếu bản vẽ vẽ ở tỉ lệ khác thì nó ko theo tỉ lệ đó, trong khi đó các kthước đo ở tỉ lệ đó vànhư vậy có mâu thuẫn giữa kthước và tổng kthước, mong bác xem lại và có thể cho bản tính tỏng đó hoànthiện hơn.

 

Rất cảm ơn bác.

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

tnmtpc    207

tnmtpc
Đã đăng
1- Vài tiện ích nhỏ, hy vọng có ích cho một số bạn thường phải xử lý Dim và Measure

2- Có vấn đề gì về sử dụng, các bạn phản hồi để ssg sửa

3- Cần bổ sung thêm những tiện ích gì thuộc dạng này không?

SSg sửa lại lệnh LL : đo và ghi chiều dài nhiều đối tượng, bỡi vì anh em địa chính sẽ rất cần cái này để ghi kích thước cạnh thửa đất, mà lệnh LL của SSG cho ra kết quả không thuộc "qui phạm", đặt biệt nếu thửa đất tạo bằng polyline kín thì nó cho kết quả chu vi chứ không phải từng cạnh.

Đây là file tham khảo

http://www.cadviet.com/upfiles/kichthuocthuadat.dwg

Mong hối âm của SSg. Thanks!

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

ui_troi_2005    5

ui_troi_2005
Đã đăng
SSg sửa lại lệnh LL : đo và ghi chiều dài nhiều đối tượng, bỡi vì anh em địa chính sẽ rất cần cái này để ghi kích thước cạnh thửa đất, mà lệnh LL của SSG cho ra kết quả không thuộc "qui phạm", đặt biệt nếu thửa đất tạo bằng polyline kín thì nó cho kết quả chu vi chứ không phải từng cạnh.

Đây là file tham khảo

http://www.cadviet.com/upfiles/kichthuocthuadat.dwg

Mong hối âm của SSg. Thanks!

 

Chào bác SSG.

 

Lệnh SCC đó sau khi sử dụng nó không thể edit size kthước đc. mong bác sửa lại hiện tại em sủa nó phải xoá đi rồi trả lại kthước cũ rồi mới thay đổi size đc..

 

Chúc bác và anh em trong diễn đàn luôn vui.

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

ssg    1.102

ssg
Đã đăng
Chào bác SSG.

 

Lệnh SCC đó sau khi sử dụng nó không thể edit size kthước đc. mong bác sửa lại hiện tại em sủa nó phải xoá đi rồi trả lại kthước cũ rồi mới thay đổi size đc..

 

Chúc bác và anh em trong diễn đàn luôn vui.

Không hiểu ý, edit size là làm gì? Tại sao không edit được?

Xin diễn giải bản chất của SCC:

- Scale toàn bộ với hệ số k do user nhập vào

- Duyệt qua tất cả các đối tượng dim bị scale

- Với từng đối tượng dim:

+ Chia Dimscale Linear với k

+ Nhân Dimscale Overall với k (nếu user chọn "Y" khi được hỏi)

Hai động tác trên tương đương với việc chọn đối tượng dim, gõ lệnh mo và sửa thủ công. Điểm khác nhau duy nhất là chương trình làm hàng loạt và tự động nên nhanh hơn "by hand". Đơn giản vậy thôi. Bạn thử làm thủ công cho 1 dim nào đó, so sánh kết quả với SCC sẽ hiểu ra thực chất vấn đề.

 

Ngoài ra, ssg xin ghi nhận các góp ý của tất cả các bạn về topic này. Tuy nhiên, ssg đang có rất nhiều việc cấp bách, "nước sôi lửa bỏng" trong công việc nên chưa xem được gì cả. Hẹn các bạn lúc nào đó thư thả hơn. Trước mắt, có lẽ ssg sẽ vắng mặt trên diễn đàn một thời gian khá dài (không xác định trước được). Mong các bạn hiểu và thông cảm cho.

Chúc anh em vui khoẻ. Good bye! See you again!

Ssg

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Đăng nhập để thực hiện theo  
Người theo dõi 0
Về Đầu Trang AutoLisp
×