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

xin lisp với mục đích đánh dấu những đường tròn có kích thước giống nhau bằng chữ cái.

Bởi Nam2604 , trong AutoLisp

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

Nam2604    1

Nam2604
Đã đăng

chào các bác ạ. Trên bản vẽ có nhiều đường tròn như này, em muốn đánh dấu những đường tròn có kích thước giống nhau bằng 1 chữ cái cái nhất định, mà chọn tay thì khá là lâu đối với những bản vẽ có nhiều đường tròn như vậy. các bác cho em xin lisp với mục đích như trên với ạ. nếu kèm theo được xuất tọa độ các lỗ ra bảng thì tuyệt vời. em cảm ơn các bác ạ

image.png

  • 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

CadExTools    110

CadExTools
Đã đăng

Cái này giống khuôn mẫu nhỉ?

Ý tưởng có thể xuất thông tin lỗ ra Excel -> Đánh mã số trên Excel dựa trên đường kính -> cập nhật lại Autocad

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

Nam2604    1

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

Cái này giống khuôn mẫu nhỉ?

Ý tưởng có thể xuất thông tin lỗ ra Excel -> Đánh mã số trên Excel dựa trên đường kính -> cập nhật lại Autocad

vâng đúng rồi bác ạ, đây là khuôn đột dập, em muốn đánh dấu những đường tròn bằng nhau bằng 1 chữ cái, rồi có thể đưa ra list tọa độ, đường kính vào 1 bảng trong cad. ý tưởng là thế 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

cuongtk2    431

cuongtk2
Đã đăng

Của bạn đây 

;; JH:list-to-table --> Jonathan Handojo
;; Creates a table from a list of lists of strings
;; space - ModelSpace or Paperspace vla object
;; lst - list of lists where each list is a list of strings
;;	=> if you wish to insert a block in the cell, prefix using "<block>" followed by the block name
;;	=> e.x. if you want to insert the block "TestBlock1", input the string as "<block>TestBlock1"
;; pt - Insertion point of table (2 or 3 reals)
;; tblstyle - Table style to use


(defun JH:list-to-table (space lst pt tblstyle / i j lens ncols rows totlen txt vtable)
    (setq ncols (apply 'max (mapcar 'length lst))
	  vtable (vla-AddTable space (vlax-3d-point pt) (length lst) ncols 10 10)
	  )
    (vla-put-RegenerateTableSuppressed vtable :vlax-true)
    (vla-put-StyleName vtable tblstyle)
    (repeat (setq i (length lst))
	(setq rows (nth (setq i (1- i)) lst))
	(vla-SetRowHeight vtable i (* 2 (vlax-invoke vtable 'GetCellTextHeight i 0)))
	(repeat (setq j (length rows))
	    (setq lens
		     (cons
			 (+
			     (abs
				 (apply '-
					(mapcar 'car
						(textbox
						    (list
							(cons 1 (setq txt (nth (setq j (1- j)) rows)))
							(cons 40 (vlax-invoke vtable 'GetCellTextHeight i j))
							(cons 7 (vlax-invoke vtable 'GetCellTextStyle i j))
							)
						    )
						)
					)
				 )
			     (vlax-invoke vtable 'GetCellTextHeight i j)
			     )
			 lens
			 )
		  )
	    (if (eq (strcase (substr txt 1 7)) "<BLOCK>")
		(progn
		    (setq blk (substr txt 8))
		    (if (and
			     (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
			     (vlax-method-applicable-p vtable 'setblocktablerecordid32)
			     )
			 (vla-SetBlockTableRecordId32 vtable i j (vla-get-ObjectID (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blk)))
			 (vla-SetBlockTableRecordId vtable i j (vla-get-ObjectID (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blk)) :vlax-true)
			 )
		    )
		(vla-SetText vtable i j txt)
		)
	    )
	(setq totlen (cons lens totlen) lens nil)
	)
    (repeat ncols
	(vla-SetColumnWidth vtable (setq ncols (1- ncols))
	    (apply 'max
		   (vl-remove nil
		       (mapcar
			   '(lambda (x)
				(nth ncols x)
				)
			   totlen
			   )
		       )
		   )
	    )
	)
    (vla-put-RegenerateTableSuppressed vtable :vlax-false)
    vtable
    )
;;;;;- tao text-----------------------------------------------------------------
(DEFUN make_text  (p1 style text chieu_cao goc_quay wid canh_le canh_le1 layer / b e_list FONT)
  (SETQ b (TBLSEARCH "style" style))
  (IF (NULL b)
    (SETQ style (GETVAR "TEXTSTYLE")))

  (SETQ e_list nil)
  (IF (= canh_le 0)

    (SETQ e_list (LIST (CONS 0 "TEXT")
                       (CONS 100 "AcDbEntity")
                       (CONS 8 layer)
                       (CONS 100 "AcDbText")
                       (cons 10 p1)
                       (CONS 40 chieu_cao)
                       (CONS 1 text)
                       (CONS 50 goc_quay)
                       (CONS 41 wid)
                       (CONS 7 style)
                       (CONS 72 canh_le)
                       (LIST 11 0.0 0.0 0.0)
                       (CONS 100 "AcDbText")
                       (CONS 39 0.0)
                       (CONS 73 canh_le1)
                       )) ; then

    (SETQ e_list (LIST (CONS 0 "TEXT")
                       (CONS 100 "AcDbEntity")
                       (CONS 8 layer)
                       (CONS 100 "AcDbText")
                       (cons 10 p1)
                       (CONS 40 chieu_cao)
                       (CONS 1 text)
                       (CONS 50 goc_quay)
                       (CONS 41 wid)
                       (CONS 7 style)
                       (CONS 72 canh_le)
                       (cons 11 p1)
                       (CONS 100 "AcDbText")
                       (CONS 39 0.0)
                       (CONS 73 canh_le1)))
    ) ;endif
  (ENTMAKE e_list)
  )


;;; ham chay
;;;;
(defun c:test( / HTEXT I LS LS1 LS2 MINRAD OB POS RAD SS)
  (setq htext (getreal "\nCao text<0.1>"))
  (if (null htext) (setq htext 0.1))



  



(setq ss (ACET-SS-TO-LIST (ssget '((0 . "CIRCLE")))))
(setq ls (mapcar 'vlax-ename->vla-object ss))
(SETQ LS1 (MAPCAR
            '(LAMBDA (OB) (CONS (vla-get-Radius OB)
                                (vlax-safearray->list(vlax-variant-value(vla-get-Center OB))))) LS
            )
      )
(SETQ LS2 (VL-SORT LS1 '(LAMBDA (A B) (<(CAR A) (CAR B)) )))
(SETQ minrad (car (car ls2))
      i 65
      toado (list (list "Thong ke cac Lo") (list "Ky hieu" "Duong kinh" "X" "Y"))
      )

(foreach n ls2
  (progn
  (setq rad (car n)
        pos (cdr n))
  (if (> rad minrad)
    (setq i (1+ i)
          minrad rad)
    )
  (make_text pos "Standards" (chr i) htext 0 1 1 2 "text")
  (setq nls (list
              (chr i) (rtos rad 2 3) (rtos (car pos) 2 3) (rtos (cadr pos) 2 3)
                                    ))
  (setq toado (append toado (list nls)))
  )
  )



  (setq doc (vla-get-activedocument (vlax-get-acad-object))
         space (if (> (getvar "CVPORT") 1)(vla-get-modelspace doc)(vla-get-paperspace doc))
   )
   ; don't run the function unless a point is acutally selected
   (if (setq pt1 (getpoint "\nSelect Insertion Point: "))
      (JH:list-to-table space toado pt1 "Standard")
   )
  )

 

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

Nam2604    1

Nam2604
Đã đăng
2 giờ trước, cuongtk2 đã nói:

Của bạn đây 


;; JH:list-to-table --> Jonathan Handojo
;; Creates a table from a list of lists of strings
;; space - ModelSpace or Paperspace vla object
;; lst - list of lists where each list is a list of strings
;;	=> if you wish to insert a block in the cell, prefix using "<block>" followed by the block name
;;	=> e.x. if you want to insert the block "TestBlock1", input the string as "<block>TestBlock1"
;; pt - Insertion point of table (2 or 3 reals)
;; tblstyle - Table style to use


(defun JH:list-to-table (space lst pt tblstyle / i j lens ncols rows totlen txt vtable)
    (setq ncols (apply 'max (mapcar 'length lst))
	  vtable (vla-AddTable space (vlax-3d-point pt) (length lst) ncols 10 10)
	  )
    (vla-put-RegenerateTableSuppressed vtable :vlax-true)
    (vla-put-StyleName vtable tblstyle)
    (repeat (setq i (length lst))
	(setq rows (nth (setq i (1- i)) lst))
	(vla-SetRowHeight vtable i (* 2 (vlax-invoke vtable 'GetCellTextHeight i 0)))
	(repeat (setq j (length rows))
	    (setq lens
		     (cons
			 (+
			     (abs
				 (apply '-
					(mapcar 'car
						(textbox
						    (list
							(cons 1 (setq txt (nth (setq j (1- j)) rows)))
							(cons 40 (vlax-invoke vtable 'GetCellTextHeight i j))
							(cons 7 (vlax-invoke vtable 'GetCellTextStyle i j))
							)
						    )
						)
					)
				 )
			     (vlax-invoke vtable 'GetCellTextHeight i j)
			     )
			 lens
			 )
		  )
	    (if (eq (strcase (substr txt 1 7)) "<BLOCK>")
		(progn
		    (setq blk (substr txt 8))
		    (if (and
			     (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
			     (vlax-method-applicable-p vtable 'setblocktablerecordid32)
			     )
			 (vla-SetBlockTableRecordId32 vtable i j (vla-get-ObjectID (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blk)))
			 (vla-SetBlockTableRecordId vtable i j (vla-get-ObjectID (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blk)) :vlax-true)
			 )
		    )
		(vla-SetText vtable i j txt)
		)
	    )
	(setq totlen (cons lens totlen) lens nil)
	)
    (repeat ncols
	(vla-SetColumnWidth vtable (setq ncols (1- ncols))
	    (apply 'max
		   (vl-remove nil
		       (mapcar
			   '(lambda (x)
				(nth ncols x)
				)
			   totlen
			   )
		       )
		   )
	    )
	)
    (vla-put-RegenerateTableSuppressed vtable :vlax-false)
    vtable
    )
;;;;;- tao text-----------------------------------------------------------------
(DEFUN make_text  (p1 style text chieu_cao goc_quay wid canh_le canh_le1 layer / b e_list FONT)
  (SETQ b (TBLSEARCH "style" style))
  (IF (NULL b)
    (SETQ style (GETVAR "TEXTSTYLE")))

  (SETQ e_list nil)
  (IF (= canh_le 0)

    (SETQ e_list (LIST (CONS 0 "TEXT")
                       (CONS 100 "AcDbEntity")
                       (CONS 8 layer)
                       (CONS 100 "AcDbText")
                       (cons 10 p1)
                       (CONS 40 chieu_cao)
                       (CONS 1 text)
                       (CONS 50 goc_quay)
                       (CONS 41 wid)
                       (CONS 7 style)
                       (CONS 72 canh_le)
                       (LIST 11 0.0 0.0 0.0)
                       (CONS 100 "AcDbText")
                       (CONS 39 0.0)
                       (CONS 73 canh_le1)
                       )) ; then

    (SETQ e_list (LIST (CONS 0 "TEXT")
                       (CONS 100 "AcDbEntity")
                       (CONS 8 layer)
                       (CONS 100 "AcDbText")
                       (cons 10 p1)
                       (CONS 40 chieu_cao)
                       (CONS 1 text)
                       (CONS 50 goc_quay)
                       (CONS 41 wid)
                       (CONS 7 style)
                       (CONS 72 canh_le)
                       (cons 11 p1)
                       (CONS 100 "AcDbText")
                       (CONS 39 0.0)
                       (CONS 73 canh_le1)))
    ) ;endif
  (ENTMAKE e_list)
  )


;;; ham chay
;;;;
(defun c:test( / HTEXT I LS LS1 LS2 MINRAD OB POS RAD SS)
  (setq htext (getreal "\nCao text<0.1>"))
  (if (null htext) (setq htext 0.1))



  



(setq ss (ACET-SS-TO-LIST (ssget '((0 . "CIRCLE")))))
(setq ls (mapcar 'vlax-ename->vla-object ss))
(SETQ LS1 (MAPCAR
            '(LAMBDA (OB) (CONS (vla-get-Radius OB)
                                (vlax-safearray->list(vlax-variant-value(vla-get-Center OB))))) LS
            )
      )
(SETQ LS2 (VL-SORT LS1 '(LAMBDA (A B) (<(CAR A) (CAR B)) )))
(SETQ minrad (car (car ls2))
      i 65
      toado (list (list "Thong ke cac Lo") (list "Ky hieu" "Duong kinh" "X" "Y"))
      )

(foreach n ls2
  (progn
  (setq rad (car n)
        pos (cdr n))
  (if (> rad minrad)
    (setq i (1+ i)
          minrad rad)
    )
  (make_text pos "Standards" (chr i) htext 0 1 1 2 "text")
  (setq nls (list
              (chr i) (rtos rad 2 3) (rtos (car pos) 2 3) (rtos (cadr pos) 2 3)
                                    ))
  (setq toado (append toado (list nls)))
  )
  )



  (setq doc (vla-get-activedocument (vlax-get-acad-object))
         space (if (> (getvar "CVPORT") 1)(vla-get-modelspace doc)(vla-get-paperspace doc))
   )
   ; don't run the function unless a point is acutally selected
   (if (setq pt1 (getpoint "\nSelect Insertion Point: "))
      (JH:list-to-table space toado pt1 "Standard")
   )
  )
  
    

 

em cảm ơn bác, bác có thể cải tiến thêm phần ghi chữ trực tiếp vào đường tròn như ảnh kia được không ạ.

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

Nam2604    1

Nam2604
Đã đăng
19 giờ trước, cuongtk2 đã nói:

Chữ đã ghi vào đường tròn, bạn nên khai báo lại chiều cao để nhìn cho rõ ( hiện đang cao 0.1)

image.png.117ccc28cfffa4e3c270ec67c6897500.png

vâng, Bác nâng cấp giúp em, ví dụ em muốn lựa chọn chữ cái cho đường kính chứ không phải auto như này ạ, với lại bác có thể cho chữ chếch sang 1 bên mà không phải vào tâm ạ

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    431

cuongtk2
Đã đăng 
;; JH:list-to-table --> Jonathan Handojo
;; Creates a table from a list of lists of strings
;; space - ModelSpace or Paperspace vla object
;; lst - list of lists where each list is a list of strings
;;	=> if you wish to insert a block in the cell, prefix using "<block>" followed by the block name
;;	=> e.x. if you want to insert the block "TestBlock1", input the string as "<block>TestBlock1"
;; pt - Insertion point of table (2 or 3 reals)
;; tblstyle - Table style to use


(DEFUN JH:list-to-table  (space lst pt tblstyle / i j lens ncols rows totlen txt vtable)
  (SETQ ncols  (APPLY 'MAX (MAPCAR 'LENGTH lst))
        vtable (VLA-ADDTABLE space (VLAX-3D-POINT pt) (LENGTH lst) ncols 10 10)
        )
  (VLA-PUT-REGENERATETABLESUPPRESSED vtable :VLAX-TRUE)
  (VLA-PUT-STYLENAME vtable tblstyle)
  (REPEAT (SETQ i (LENGTH lst))
    (SETQ rows (NTH (SETQ i (1- i)) lst))
    (VLA-SETROWHEIGHT vtable i (* 2 (VLAX-INVOKE vtable 'GetCellTextHeight i 0)))
    (REPEAT (SETQ j (LENGTH rows))
      (SETQ lens
             (CONS
               (+
                 (ABS
                   (APPLY '-
                          (MAPCAR 'CAR
                                  (TEXTBOX
                                    (LIST
                                      (CONS 1 (SETQ txt (NTH (SETQ j (1- j)) rows)))
                                      (CONS 40 (VLAX-INVOKE vtable 'GetCellTextHeight i j))
                                      (CONS 7 (VLAX-INVOKE vtable 'GetCellTextStyle i j))
                                      )
                                    )
                                  )
                          )
                   )
                 (VLAX-INVOKE vtable 'GetCellTextHeight i j)
                 )
               lens
               )
            )
      (IF (EQ (STRCASE (SUBSTR txt 1 7)) "<BLOCK>")
        (PROGN
          (SETQ blk (SUBSTR txt 8))
          (IF (AND
                (WCMATCH (GETENV "PROCESSOR_ARCHITECTURE") "*64*")
                (VLAX-METHOD-APPLICABLE-P vtable 'setblocktablerecordid32)
                )
            (vla-SetBlockTableRecordId32
              vtable
              i
              j
              (VLA-GET-OBJECTID (VLA-ITEM (VLA-GET-BLOCKS (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) blk)))
            (VLA-SETBLOCKTABLERECORDID
              vtable
              i
              j
              (VLA-GET-OBJECTID (VLA-ITEM (VLA-GET-BLOCKS (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) blk))
              :VLAX-TRUE)
            )
          )
        (VLA-SETTEXT vtable i j txt)
        )
      )
    (SETQ totlen (CONS lens totlen)
          lens   nil)
    )
  (REPEAT ncols
    (VLA-SETCOLUMNWIDTH vtable
                        (SETQ ncols (1- ncols))
                        (APPLY 'MAX
                               (VL-REMOVE nil
                                          (MAPCAR
                                            '(LAMBDA (x)
                                               (NTH ncols x)
                                               )
                                            totlen
                                            )
                                          )
                               )
                        )
    )
  (VLA-PUT-REGENERATETABLESUPPRESSED vtable :VLAX-FALSE)
  vtable
  )

;;; ham chay
;;;;
(DEFUN c:test  (/ ob DOC GOC_QUAY NLS OB PT1 SPACE TOADO HTEXT I LS LS1 LS2 MINRAD OB POS RAD SS)
  (SETQ htext (GETREAL "\nCao text<100>"))
  (IF (NULL htext)
    (SETQ htext 100))

  (SETQ ss (ACET-SS-TO-LIST (SSGET '((0 . "CIRCLE")))))
  (SETQ ls (MAPCAR 'VLAX-ENAME->VLA-OBJECT ss))
  (SETQ LS1 (MAPCAR
              '(LAMBDA (OB)
                 (CONS (VLA-GET-RADIUS OB)
                       (VLAX-SAFEARRAY->LIST (VLAX-VARIANT-VALUE (VLA-GET-CENTER OB)))))
              LS
              )
        )
  (SETQ LS2 (VL-SORT LS1 '(LAMBDA (A B) (< (CAR A) (CAR B)))))
  (SETQ minrad (CAR (CAR ls2))
        i      65
        toado  (LIST (LIST "Thong ke cac Lo") (LIST "Ky hieu" "Duong kinh" "X" "Y"))
        )

  (FOREACH n  ls2
    (PROGN
      (SETQ rad (CAR n)
            pos (CDR n))
      (IF (> rad minrad)
        (SETQ i (1+ i)
              minrad rad)
        )
      (ENTMAKE
        (LIST (CONS 0 "TEXT")
              (CONS 100 "AcDbEntity")
              (CONS 8 "text")
              (CONS 100 "AcDbText")
              (CONS 10 pos)
              (CONS 40 htext)
              (CONS 1 (CHR i))
              (CONS 50 0)
              (CONS 41 1)
              (CONS 7 "Standards")
              (CONS 72 0)
              (LIST 11 0.0 0.0 0.0)
              (CONS 100 "AcDbText")
              (CONS 39 0.0)
              (CONS 73 0)
              )) ; entmake   
      (SETQ nls (LIST
                  (CHR i)
                  (RTOS (* 2.0 rad) 2 3)
                  (RTOS (CAR pos) 2 3)
                  (RTOS (CADR pos) 2 3)
                  ))
      (SETQ toado (APPEND toado (LIST nls)))
      )
    )

  (SETQ doc   (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))
        space (IF (> (GETVAR "CVPORT") 1)
                (VLA-GET-MODELSPACE doc)
                (VLA-GET-PAPERSPACE doc))
        )
 ; don't run the function unless a point is acutally selected
  (IF (SETQ pt1 (GETPOINT "\nSelect Insertion Point: "))
    (JH:list-to-table space toado pt1 "Standard")
    )
  )
;|«Visual LISP© Format Options»
(180 2 1 0 nil "end of " 100 20 2 0 0 nil T nil T)
;*** DO NOT add text below the comment! ***|;

Anh đã điều chỉnh cho text just thành Bottom Left. Cao chữ mặc định 100.

Tuy nhiên để khai báo chữ cho từng đường kính thì phải thông qua 1 hộp thoại, hoặc viết thành 2 lệnh riêng biệt: lệnh 1 - điền chữ  cho 1 loại đường kính, lệnh 2 - Thống kê đường tròn đã có chữ trong đó.

  • 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

cuongtk2    431

cuongtk2
Đã đăng 
;;; 1. Chon duong tron mau
;;; 2. Select toan bo duong tron de loc ban kinh theo mau
;;; 3. Dien ten ky hieu
;;; 4. Khai bao cao text

(defun c:lenh1 ( / DK HTEXT SS STR)
  (setq dk (acet-dxf 40 (entget (car (entsel "\nDuong tron mau:")))))
  (prompt "\nChon cac duong tron")
   (setq ss (ACET-SS-TO-LIST (ssget (list (cons 0 "CIRCLE") (cons 40 dk))))
        )
  (setq str (getstring "\nKy hieu:"))
  (if (null str) (exit))
  (SETQ htext (GETREAL "\nCao text<100>"))
  (IF (NULL htext)
    (SETQ htext 100))
  (foreach ent ss
    (ENTMAKE
        (LIST (CONS 0 "TEXT")
              (CONS 100 "AcDbEntity")
              (CONS 8 "text")
              (CONS 100 "AcDbText")
              (CONS 10 (acet-dxf 10 (entget ent)))
              (CONS 40 htext)
              (CONS 1 str)
              (CONS 50 0)
              (CONS 41 1)
              (CONS 7 (getvar "textstyle"))
              (CONS 72 0)
              (LIST 11 0.0 0.0 0.0)
              (CONS 100 "AcDbText")
              (CONS 39 0.0)
              (CONS 73 0)
              )) ; entmake
    )
  )

 

  • 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

cuongtk2    431

cuongtk2
Đã đăng 
(defun c:lenh2 ( / DOC LSCIRCLE LSTEXT PT1 SPACE SS TOADO)
  (setq ss (mapcar 'vlax-ename->vla-object (ACET-SS-TO-LIST (ssget '((0 . "CIRCLE,TEXT"))))))
  (setq lstext (vl-sort
         (vl-remove-if-not '(lambda (o) (= (vla-get-ObjectName o) "AcDbText" )) ss)
         '(lambda (o1 o2) ( < (vla-get-TextString o1) (vla-get-TextString o2))))
        )
  (setq lscircle (vl-remove-if-not '(lambda (o) (= (vla-get-ObjectName o) "AcDbCircle" )) ss))
  (setq toado  (LIST (LIST "Thong ke cac Lo") (LIST "Ky hieu" "Duong kinh" "X" "Y")))

  (foreach obj lstext
    (SETQ toado (APPEND toado (LIST (get-cicrle->text obj lscircle))))
    )
    
(SETQ doc   (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))
        space (IF (> (GETVAR "CVPORT") 1)
                (VLA-GET-MODELSPACE doc)
                (VLA-GET-PAPERSPACE doc))
        )
 ; don't run the function unless a point is acutally selected
  (IF (SETQ pt1 (GETPOINT "\nSelect Insertion Point: "))
    (JH:list-to-table space toado pt1 "Standard")
    )
  )
  

(defun get-cicrle->text (obj ls / CI LS1 NLS NOIDUNG POS RAD)
  (setq pos (vlax-safearray->list (vlax-variant-value(vla-get-InsertionPoint obj)))
        ls1 (vl-sort ls '(lambda (o1 o2)
                        (< (distance (vlax-safearray->list (vlax-variant-value(vla-get-Center o1))) pos)
                           (distance (vlax-safearray->list (vlax-variant-value(vla-get-Center o2))) pos)
                           )
                        
                        )
                     )
        ci (car ls1)
        rad (vla-get-Radius ci)
        noidung (vla-get-TextString obj)
        )
  (SETQ nls (LIST
                  noidung
                  (RTOS (* 2.0 rad) 2 3)
                  (RTOS (CAR pos) 2 3)
                  (RTOS (CADR pos) 2 3)
                  ))
              
  )

;; JH:list-to-table --> Jonathan Handojo
;; Creates a table from a list of lists of strings
;; space - ModelSpace or Paperspace vla object
;; lst - list of lists where each list is a list of strings
;;	=> if you wish to insert a block in the cell, prefix using "<block>" followed by the block name
;;	=> e.x. if you want to insert the block "TestBlock1", input the string as "<block>TestBlock1"
;; pt - Insertion point of table (2 or 3 reals)
;; tblstyle - Table style to use


(DEFUN JH:list-to-table  (space lst pt tblstyle / i j lens ncols rows totlen txt vtable)
  (SETQ ncols  (APPLY 'MAX (MAPCAR 'LENGTH lst))
        vtable (VLA-ADDTABLE space (VLAX-3D-POINT pt) (LENGTH lst) ncols 10 10)
        )
  (VLA-PUT-REGENERATETABLESUPPRESSED vtable :VLAX-TRUE)
  (VLA-PUT-STYLENAME vtable tblstyle)
  (REPEAT (SETQ i (LENGTH lst))
    (SETQ rows (NTH (SETQ i (1- i)) lst))
    (VLA-SETROWHEIGHT vtable i (* 2 (VLAX-INVOKE vtable 'GetCellTextHeight i 0)))
    (REPEAT (SETQ j (LENGTH rows))
      (SETQ lens
             (CONS
               (+
                 (ABS
                   (APPLY '-
                          (MAPCAR 'CAR
                                  (TEXTBOX
                                    (LIST
                                      (CONS 1 (SETQ txt (NTH (SETQ j (1- j)) rows)))
                                      (CONS 40 (VLAX-INVOKE vtable 'GetCellTextHeight i j))
                                      (CONS 7 (VLAX-INVOKE vtable 'GetCellTextStyle i j))
                                      )
                                    )
                                  )
                          )
                   )
                 (VLAX-INVOKE vtable 'GetCellTextHeight i j)
                 )
               lens
               )
            )
      (IF (EQ (STRCASE (SUBSTR txt 1 7)) "<BLOCK>")
        (PROGN
          (SETQ blk (SUBSTR txt 8))
          (IF (AND
                (WCMATCH (GETENV "PROCESSOR_ARCHITECTURE") "*64*")
                (VLAX-METHOD-APPLICABLE-P vtable 'setblocktablerecordid32)
                )
            (vla-SetBlockTableRecordId32
              vtable
              i
              j
              (VLA-GET-OBJECTID (VLA-ITEM (VLA-GET-BLOCKS (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) blk)))
            (VLA-SETBLOCKTABLERECORDID
              vtable
              i
              j
              (VLA-GET-OBJECTID (VLA-ITEM (VLA-GET-BLOCKS (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))) blk))
              :VLAX-TRUE)
            )
          )
        (VLA-SETTEXT vtable i j txt)
        )
      )
    (SETQ totlen (CONS lens totlen)
          lens   nil)
    )
  (REPEAT ncols
    (VLA-SETCOLUMNWIDTH vtable
                        (SETQ ncols (1- ncols))
                        (APPLY 'MAX
                               (VL-REMOVE nil
                                          (MAPCAR
                                            '(LAMBDA (x)
                                               (NTH ncols x)
                                               )
                                            totlen
                                            )
                                          )
                               )
                        )
    )
  (VLA-PUT-REGENERATETABLESUPPRESSED vtable :VLAX-FALSE)
  vtable
  )

 

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
×