Đến nội dung


Hình ảnh
- - - - -

[Nhờ chỉnh sửa] Lisp tính diện tích bằng Pick Điểm


  • Please log in to reply
7 replies to this topic

#1 NguyenNgocSon

NguyenNgocSon

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 368 Bài viết
Điểm đánh giá: 39 (tàm tạm)

Đã gửi 27 April 2013 - 10:11 AM

(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast)
  (vl-load-com)

  (defun *error* (msg)
    (ObjRel (list xlApp xlCells))
    (and ov (mapcar 'setvar vl ov))
    (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\n** Error: " msg " **")))
    (princ))

  (setq vl '("CMDECHO" "OSMODE") ov (mapcar 'getvar vl))

  (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 1)

  (while (setq pt (getpoint "\nPick Area: "))

    (mapcar 'setvar vl '(0 0))
    (setq eLast (entlast))
    (vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")

    (if (not (eq elast (setq ent (entlast))))
      (progn
        (vlax-put-property xlCells 'Item row 1
          (rtos
            (vlax-get-property (vlax-ename->vla-object ent) 'Area)))
        
        (entdel ent)
        (setq Row (1+ Row))))
    
    (mapcar 'setvar vl ov))

  (vlax-put-property xlApp 'Visible :vlax-true)
  (ObjRel (list xlApp xlCells))
  (gc) (gc)
  
  (mapcar 'setvar vl ov)
  (princ))
(defun ObjRel (lst)
  (mapcar
    (function
      (lambda (x)
        (if (and (eq (type x) 'VLA-OBJECT)
                 (not (vlax-object-released-p x)))
          (vl-catch-all-apply
            'vlax-release-object (list x))))) lst))

Mình có cái lisp này thấy rất hay nhưng có điều giờ mình muốn khi pick vào miền thì sẽ tạo luôn Hatch bao quanh miền đó và có 1 text ghi số thứ tự. Mong các bạn giúp vì cái lisp này dùng nhiều hàm -Vla quá mình không rành lắm

Cám ơn!


  • 0

#2 thehost31

thehost31

    biết vẽ line

  • Members
  • PipPip
  • 26 Bài viết
Điểm đánh giá: 17 (tàm tạm)

Đã gửi 28 April 2013 - 01:09 AM

Đã chỉnh sửa cho bạn. Tớ chỉ thêm các hàm con bên trên và thêm vào khoảng 4 câu lệnh trong hàm cũ của bạn. Mấy hàm con copy của ông Demigod bên trạm X.vn. Hy vọng giải quyết được yêu cầu của bạn. Tuy nhiên chưa điền tỷ lệ hatch và chiều cao text hợp lý. Kiểu Hatch tớ chọn ANSI31 và chiều cao chữ 1.5.

 

 

(defun Add_Hatch(poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
(setq hatch (vla-AddHatch mspace acHatchPatternTypePreDefined Htype :vlax-True))
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist(obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)
;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(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 1
)

(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(vlax-put-property
xlCells
'Item
row
1
(setq dtich (rtos (vlax-get-property (vlax-ename->vla-object ent) 'Area)));;;
)
;;;;;;;;;
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist)) (length plist))
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist)) (length plist))
)
)
(MCText Pgiua dtich 1.5)
;;;;;;;;;
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)

(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)

(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)


  • 1

#3 NguyenNgocSon

NguyenNgocSon

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 368 Bài viết
Điểm đánh giá: 39 (tàm tạm)

Đã gửi 01 May 2013 - 10:06 AM

Cám ơn bạn nhiều :)


  • 0

#4 anhemTracdia

anhemTracdia

    biết zoom

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

Đã gửi 01 May 2013 - 11:59 AM

Đã chỉnh sửa cho bạn. Tớ chỉ thêm các hàm con bên trên và thêm vào khoảng 4 câu lệnh trong hàm cũ của bạn. Mấy hàm con copy của ông Demigod bên trạm X.vn. Hy vọng giải quyết được yêu cầu của bạn. Tuy nhiên chưa điền tỷ lệ hatch và chiều cao text hợp lý. Kiểu Hatch tớ chọn ANSI31 và chiều cao chữ 1.5.

 

 

(defun Add_Hatch(poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
(setq hatch (vla-AddHatch mspace acHatchPatternTypePreDefined Htype :vlax-True))
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist(obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)
;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(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 1
)

(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(vlax-put-property
xlCells
'Item
row
1
(setq dtich (rtos (vlax-get-property (vlax-ename->vla-object ent) 'Area)));;;
)
;;;;;;;;;
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist)) (length plist))
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist)) (length plist))
)
)
(MCText Pgiua dtich 1.5)
;;;;;;;;;
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)

(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)

(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)

Cám ơn các Bạn, Lisp này rất hay tính dien tich nhanh và xuất thẳng ra excel.

Nhưng khi xuất ra excel phải mò lại diẹn tích của từng đối tượng để xử lý, hơi bị rắt rối tí...

Mình nhờ Bạn chỉnh giúp :

1. Khi lick chọn đối tượng để tính diện tích, lisp ghi hàng trên là Số thứ tự, hàng dưới là diện tích, xuất ra excel (stt - Dien tich ) cùng tên với Cad và ghi nối tiếp vào bảng excel cũ ( nếu có ).

2. Trường hơp 2 : Chọn text,D,Mtext,.. tên nội dung của vùng cần tính, click và vùng tính diện tích, ---> xuất ra excel (tên nội dung - Dien tich ) và như yêu cầu (1).

Rất mong được Bạn giúp


  • 0

#5 thehost31

thehost31

    biết vẽ line

  • Members
  • PipPip
  • 26 Bài viết
Điểm đánh giá: 17 (tàm tạm)

Đã gửi 01 May 2013 - 10:15 PM

Chỉnh sửa lại tí nửa theo ý bạn anhemtracdia

 

Sau khi Pick điểm xác định vùng tính diện tích. Nếu muốn chọn text chứa tên của vùng thì chọn text hoặc mtext. Nếu muốn dùng tên tự động thì chuột phải hoặc enter để tiếp. Tên tự động có dạng Si.

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/70735-nho-chinh-sua-lisp-tinh-dien-tich-bang-pick-diem/
(defun Add_Hatch (poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-Acad-Object))
)
)
(setq hatch (vla-AddHatch
mspace
acHatchPatternTypePreDefined
Htype
:vlax-True
)
)
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun MLText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 0) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist (obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)


;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist
pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(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 1
dem 1
)
(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(setq vitri (car (entsel "\nSelect Area Name text: ")))
(if vitri
(setq vitri (cdr (assoc 1 (entget vitri))))
(setq vitri (strcat "S" (rtos dem 2 0)) dem (1+ dem))
)
(vlax-put-property
xlCells
'Item
row
1
vitri
)
(vlax-put-property
xlCells
'Item
row
2
(setq dtich (rtos (vlax-get-property
(vlax-ename->vla-object ent)
'Area
)
)
)
)
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq
Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist))
(length plist)
)
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist))
(length plist)
)
)
)
(setq Pstt (polar pgiua (* 0.5 pi) 1.5))
(setq Parea (polar pgiua (* -0.5 pi) 1.5))
(MLText Pstt vitri 1.5)
(MLText Parea dtich 1.5)
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)
(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)
(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)

 

Chúc thành công!


  • 3

#6 anhemTracdia

anhemTracdia

    biết zoom

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

Đã gửi 02 May 2013 - 11:02 AM

Cám ơn.

Bạn xem lại giúp : diện tích tính và ghi trên Cad thì đúng, nhưng khi xuất ra excel thì diện tich tăng lên 10 lần đó bạn.

Mình nhờ bạn giúp thêm về việc xuất nội dung chọn ra excel cùng với diện tích, vớ số lượng nhiều nội dung. Đấu tiên ta click tính diện tích, sau đó chọn nhiều nội dung để xuất tiếp, như : STT ô ( A:1), cao độ tụ nhiên 1, 2, 3,...( qui  định không quá 12 cột CDTN), đến (N:1) cột trống và diện tích và cột thứ 15 (O:1). Ghi nối tiếp vào file Excel .


  • 0

#7 anhemTracdia

anhemTracdia

    biết zoom

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

Đã gửi 02 May 2013 - 11:07 AM

Goi file kèm theo

http://www.cadviet.c...at_ra_excel.rar


  • 0

#8 vuongpv

vuongpv

    Chưa sử dụng CAD

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

Đã gửi 10 November 2016 - 09:41 AM

Chỉnh sửa lại tí nửa theo ý bạn anhemtracdia

 

Sau khi Pick điểm xác định vùng tính diện tích. Nếu muốn chọn text chứa tên của vùng thì chọn text hoặc mtext. Nếu muốn dùng tên tự động thì chuột phải hoặc enter để tiếp. Tên tự động có dạng Si.

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/70735-nho-chinh-sua-lisp-tinh-dien-tich-bang-pick-diem/
(defun Add_Hatch (poly Htype / mspace)
(vl-load-com)
(setq mspace (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-Acad-Object))
)
)
(setq hatch (vla-AddHatch
mspace
acHatchPatternTypePreDefined
Htype
:vlax-True
)
)
(vlax-invoke hatch 'AppendOuterLoop (list poly))
(vla-evaluate hatch)
)
;==============================================================
(defun MCText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 1) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun MLText (pt string ht / mspace thetext tent alpoint)
(vl-load-com)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq thetext (vla-AddText mspace string (vlax-3d-point pt) ht))
(setq tent (entget (vlax-vla-object->ename thetext)))
(setq alpoint (cdr (assoc 10 tent)))
(setq tent (subst (cons 73 2) (assoc 73 tent) tent))
(setq tent (subst (cons 72 0) (assoc 72 tent) tent))
(setq tent (subst (cons 11 alpoint) (assoc 11 tent) tent))
(entmod tent)
thetext
)
;==============================================================
(defun obj2plist (obj-ename / en timp timl pli)
(if (= (cdr (assoc 0 (entget obj-ename))) "LINE")
(progn
(setq timp (list
(cdr (assoc 10 (entget obj-ename)))
(cdr (assoc 11 (entget obj-ename)))
)
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "POLYLINE")
(progn
(setq en obj-ename)
(while (/= (cdr (assoc 0 (entget en))) "SEQEND")
(if (= (cdr (assoc 0 (entget en))) "VERTEX")
(setq timp (append timp (list (cdr (assoc 10 (entget en))))))
)
(setq en (entnext en))
)
)
)
(if (= (cdr (assoc 0 (entget obj-ename))) "LWPOLYLINE")
(progn
(setq timl (entget obj-ename))
(setq pli 0)
(while (< pli (length timl))
(if (= (car (nth pli timl)) 10)
(setq timp (append timp (list (cdr (nth pli timl)))))
)
(setq pli (1+ pli))
)
)
)
timp
)


;==============================================================
(defun c:A2xl (/ *error* vl ov xlApp xlCells Row pt eLast dtich plist
pgiua)
(vl-load-com)
(defun *error* (msg)
(ObjRel (list xlApp xlCells))
(and ov (mapcar 'setvar vl ov))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(setq vl '("CMDECHO" "OSMODE")
ov (mapcar 'getvar vl)
)
(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 1
dem 1
)
(while (setq pt (getpoint "\nPick Area: "))
(mapcar 'setvar vl '(0 0))
(setq eLast (entlast))
(vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" pt "")
(if (not (eq elast (setq ent (entlast))))
(progn
(setq vitri (car (entsel "\nSelect Area Name text: ")))
(if vitri
(setq vitri (cdr (assoc 1 (entget vitri))))
(setq vitri (strcat "S" (rtos dem 2 0)) dem (1+ dem))
)
(vlax-put-property
xlCells
'Item
row
1
vitri
)
(vlax-put-property
xlCells
'Item
row
2
(setq dtich (rtos (vlax-get-property
(vlax-ename->vla-object ent)
'Area
)
)
)
)
(ADD_HATCH (vlax-ename->vla-object ent) "ANSI31")
(setq plist (OBJ2PLIST ent))
(setq
Pgiua (list
(/ (apply '+ (mapcar '(lambda (x) (car x)) plist))
(length plist)
)
(/ (apply '+ (mapcar '(lambda (x) (cadr x)) plist))
(length plist)
)
)
)
(setq Pstt (polar pgiua (* 0.5 pi) 1.5))
(setq Parea (polar pgiua (* -0.5 pi) 1.5))
(MLText Pstt vitri 1.5)
(MLText Parea dtich 1.5)
(entdel ent)
(setq Row (1+ Row))
)
)
(mapcar 'setvar vl ov)
)
(vlax-put-property xlApp 'Visible :vlax-true)
(ObjRel (list xlApp xlCells))
(gc)
(gc)
(mapcar 'setvar vl ov)
(princ)
)
;==============================================================
(defun ObjRel (lst)
(mapcar
(function
(lambda (x)
(if (and (eq (type x) 'VLA-OBJECT)
(not (vlax-object-released-p x))
)
(vl-catch-all-apply
'vlax-release-object
(list x)
)
)
)
)
lst
)
)

 

Chúc thành công!

Mình đã dùng thử lisp của bạn! Mình thấy lisp rất hay!

Tuy nhiên do yêu cầu công việc của mình, cần phải pick khối lượng nhiều khối lượng trên một mặt cắt (xuất ra tổng khối lượng của mặt cắt). Mà bản vẽ có nhiều mặt cắt nên mình nhờ bạn sửa lisp trên theo một số ý như:

1. Thêm 1 đoạn code nữa để gộp khối lượng trong 1 mặt cắt, xuất ra (tương tự cái S1 trong lisp).

2. Thay thế việc tự động đặt vị trí của số hiệu, khối lượng bằng việc chọn vị trí đặt.

Rất mong phản hồi của bạn!


  • 0