Chuyển đến nội dung
Diễn đàn CADViet
hoangtienphuchung2014

Nhờ viết Lsp xuất khoảng cách cọc GPMB đến tim

Bởi hoangtienphuchung2014 , trong AutoLisp

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

hoangtienphuchung2014    0

hoangtienphuchung2014
Đã đăng

Cảm ơn bạn @cuongkt2 rất nhiều! Mình muốn mở rộng thêm một chút nữa phiền bạn giúp đỡ.

- Trường hợp không phải cọc GPMB mà là các cột điện hoặc biển báo giao thông thì lúc đó không phải là đường tim 2 bên nữa mà chỉ có block thôi! Bạn giúp mình nhé! Cảm ơn bạn nhiều

 

 

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

cuongtk2    348

cuongtk2
Đã đăng

nguyên lý của cái này khác hẳn cái trước nhé bạn, với trường hợp trước bạn không cần phải cắm mốc, còn trường hợp này sẽ thống kê các mốc (block) theo lý trình. Bạn cứ gửi bản vẽ mô tả cụ thể rồi mình sẽ giải quyết.

 

  • Like 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

huunhantvxdts    195

huunhantvxdts
Đã đăng
5 giờ trước, hoangtienphuchung2014 đã nói:

Cảm ơn bạn nhé! nhưng bạn ơi mình lại phiền bạn sửa một chút là mình cần toạ độ và khoảng cách tại tâm block bạn ạ. Block có tên : "GPMBL"

Bạn nên chuyển điểm góc block tại tâm block bạn nhé, như trên tác giã đã nói. Chứ xác định tâm block sẽ không khả thi đâu

  • Like 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

huunhantvxdts    195

huunhantvxdts
Đã đăng
1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Ý mình là LSP GPMB hôm đầu bạn gửi là Ok rồi! nhưng giờ mình muốn xuất toạ độ tâm block và khoảng cách một loại block bất kỳ  

file_mau_block.dwg

Cái này không biết đúng ý bạn chưa?? tính khoảng cách từ điểm đặt block đến tim tuyến nhé (tâm block trùng điểm đặt bock nếu tâm ở vị trí khác thì bạn phải chuyển điểm đặt block đến đấy nhé)

Lưu ý. Tim tuyến chuyển về đối tượng Polyline nhé 

(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))

(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl)) lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)

 

  • Like 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

hoangtienphuchung2014    0

hoangtienphuchung2014
Đã đăng
Vào lúc 26/6/2020 tại 15:56, huunhantvxdts đã nói:

Cái này không biết đúng ý bạn chưa?? tính khoảng cách từ điểm đặt block đến tim tuyến nhé (tâm block trùng điểm đặt bock nếu tâm ở vị trí khác thì bạn phải chuyển điểm đặt block đến đấy nhé)

Lưu ý. Tim tuyến chuyển về đối tượng Polyline nhé 


(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))

(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl)) lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)

 

Bạn có thể giúp mình thêm một cột tên cọc theo mẫu này được không? Cảm ơn bạn trước

FILE_NEW.rar

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

huunhantvxdts    195

huunhantvxdts
Đã đăng
1 giờ} trướ}c, hoangtienphuchung2014 đã nói:

Bạn có thể giúp mình thêm một cột tên cọc theo mẫu này được không? Cảm ơn bạn trước

FILE_NEW.rar

Sửa lại cho bạn nhé 

(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i tentag)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))
(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq tentag (LM:vl-getattributevalue (vlax-ename->vla-object ent) "TEN-DC"))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl tentag))  lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block" "Ten coc"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)
(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

 

  • Like 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

hoangtienphuchung2014    0

hoangtienphuchung2014
Đã đăng
1 giờ trước, huunhantvxdts đã nói:

Sửa lại cho bạn nhé 


(defun C:XBL (/ cur_lay oldos lsttk timpl pointbl lst tenbl pointvg lytrinh chieudai xlApp xlCells row col sott tieude i tentag)
(setq cur_lay (getvar "clayer" ))
(setq oldos (getvar "OSMODE"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
;;;;;;;;;;;;;;;;;;;;;;;
(prompt "\nChon doi tuong Block:")
(setq lsttk (ST:acet-ss-to-list (ssget '((0 . "INSERT")))))
(setq lsttk (vl-remove-if-not '(lambda(x) (/= (cdr (assoc 2 (entget x))) "STATIONX"))  lsttk))
;(setq tiento (getstring "\nNhap tien to dien tich:"))
(setq timpl (car (LM:SelectIf "\Chon tim tuyen" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) nentsel nil)))
(setq lst nil)
(foreach ent lsttk
(setq pointbl (cdr (assoc 10 (entget ent))))
(setq tenbl (cdr (assoc 2 (entget ent))))
(setq pointvg (vlax-curve-getClosestPointTo timpl pointbl))
(setq chieudai (distance pointbl pointvg))
(setq lytrinh (vlax-curve-getDistAtPoint timpl pointvg))
(setq tentag (LM:vl-getattributevalue (vlax-ename->vla-object ent) "TEN-DC"))
(setq lst (append (list (list (rtos lytrinh 2 2) (car pointbl) (cadr pointbl) (rtos chieudai 2 2) tenbl tentag))  lst))
)
(setq lst (vl-sort lst '(lambda (x1 x2) (< (atof (car x1)) (atof (car x2))))))
(setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 2 col 1)
(vla-put-visible xlApp :vlax-true)
(setq tieude (list "STT" "Ly trinh" "toa do X" "toa do y" "Khoang cach" "Ten Block" "Ten coc"))
(setq i -1)
(repeat (length tieude)
(vlax-put-property xlCells "Item" row (+ col (setq i (1+ i))) (nth i tieude))
)
(setq sott 0)
(foreach in lst
(setq sott (+ sott 1))
(setq i 0 row (1+ row))
(vlax-put-property xlCells "Item" row 1 sott)
(foreach ent in
(vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) ent)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setvar "clayer" cur_lay)
(setvar "osmode" oldos)
(setvar "CMDECHO" 1)
)
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun ST:acet-ss-to-list (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons  e l))
)
)
(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

 

Cảm ơn bạn rất nhiều! 

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
Về Đầu Trang AutoLisp
×