Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
hatieu

Nhờ giải thích về vla-....???

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

hatieu    13

Các bác giúp em với. Mấy cái này học ở trong mấy tài liệu về lisp không có. Mong các bác giúp đỡ.

Như đoạn lisp của bác Giabach:

;; free lisp from cadviet.com
(defun c:BlkQty (/ blk_id blk_len blk_name blks ent h header_lsp height i j
	 len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com			;;
(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
 (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
 (foreach itm (vlax-for itm objTblStyDic
	 (setq tabLst (append tabLst (list itm))))
(if (not
  (vl-catch-all-error-p
	(setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
  (setq nameLst (append nameLst (list name)))  )  )
 (if (not (vl-position tbl_name nameLst))
(vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
 (setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
 (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
	  (list acTitleRow acHeaderRow acDataRow) )
 (vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
 (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
(vlax-invoke-method *util 'GetObjectIdString obj :vlax-false )
(vla-get-Objectid obj)))  
;main
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
(progn
  (vl-load-com)
  (setq i -1 len0 8)
  (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (cdr (assoc 2 (entget ent))))
(if (> (setq blk_len (strlen blk_name)) len0)
  (setq str blk_name len0 blk_len) )	
(if (not (assoc blk_name lst_blk))
  (setq lst_blk (cons (cons blk_name 1) lst_blk))
  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
			   (assoc blk_name lst_blk) lst_blk)))		)
  (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
  (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
  (initget 6)
  (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))	  
  (if h (setq *h* h) (setq h *h*) )
  (or *adoc (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
  (setq msp (vla-get-modelspace *adoc)
	*util (vla-get-Utility *adoc)
	blks (vla-get-blocks *adoc))	  
  (setq width1 (* 2 (TxtWidth "STT" h msp))
	width (* 2 (TxtWidth "So luong" h msp))
	height (* 2 h))
  (if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
  (if (> h 3)
(setq width (* (fix (/ width 10))10)
	  width1 (* (fix (/ width1 10))10)
	  width2 (* (fix (/ width2 10))10)
	  height (* (fix (/ height 5))5)))
  (GetOrCreateTableStyle "CadViet")
  (setq pt (getpoint "\nDiem dat Bang :")
	TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
  (vla-put-regeneratetablesuppressed TblObj :vlax-true)
  (vla-SetColumnWidth TblObj 0 width1)
  (vla-SetColumnWidth TblObj 1 width2)
  (vla-put-vertcellmargin TblObj (* 0.75 h))
  (vla-put-horzcellmargin TblObj (* 0.75 h))
  (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
	  (list acTitleRow acHeaderRow acDataRow) )
  (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
	  (list acTitleRow acHeaderRow acDataRow))	  
  (vla-MergeCells TblObj 0 0 0 4)
  (vla-setText TblObj 0 0 "Bang thong ke")
  (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
  (repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
  (setq row 2 i 1)	
  (foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
	(list i blk_name "cai" (cdr pt)))
(vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true)
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i))	)
  (vla-put-regeneratetablesuppressed TblObj :vlax-false)
  (vlax-release-object TblObj) )  )
 (princ))

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  

×