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

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

Bởi NguyenNgocSon , trong AutoLisp

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

NguyenNgocSon    43

NguyenNgocSon
Đã đăng 

(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!

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

thehost31    19

thehost31
Đã đăng

Đã 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
)
)
  • 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

anhemTracdia    2

anhemTracdia
Đã đăng

Đã 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

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

thehost31    19

thehost31
Đã đăng

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!

  • Vote tăng 3

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

anhemTracdia    2

anhemTracdia
Đã đăng

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 .

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

vuongpv    0

vuongpv
Đã đăng

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!

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
×