huunhantvxdts
-
Số lượng nội dung
854 -
Đã tham gia
-
Lần ghé thăm cuối
-
Ngày trúng
40
Bài đăng được đăng bởi huunhantvxdts
-
-
24 phút trước, ronaldo2002 đã nói:Em có cái lisp chọn đối tượng là các polyline với chiều dài nhập trước. Nhưng khi nhập xong chiều dài thì chọn đối tượng các polyline đã sáng lên rồi nhưng kết thúc lệnh lại ko chọn được cái polyline này, mong anh chị em xem và sửa giúp em
CODE :
(defun c:CLL (/ length filter selection)
(setq length (getreal "\nEnter the exact length: "))
;; Tạo điều kiện để lọc polyline
(setq filter (list '(0 . "LWPOLYLINE") '(70 . 0)))
;; Sử dụng hàm ssget để lọc ra các polyline thỏa mãn điều kiện
(setq selection (ssget "_:L" filter))
(if selection
(progn
(setq i 0)
(repeat (sslength selection)
(setq polyline (ssname selection i))
;; Kiểm tra chiều dài chính xác của polyline
(if (= (cdr (assoc 40 (entget polyline))) length)
(entmod (list (cons 8 "0") polyline)) ; Chọn polyline
)
(setq i (1+ i))
)
(princ "\nPolyline selected.")
)
(princ "\nNo polylines found.")
)
(princ)
)
Mình thấy bạn chỗ điều kiện lọc đã sai rồi, mã 40 là chiều rộng của polyline mà
(entmod (list (cons 8 "0") polyline)) ; hàm này là hàm updata lại đối tượng mà đâu phải hàm thêm đối tượng vào tập chọn
bạn sử dùng hàm này nhé:
(setq ss (ssadd polyline ss)
-
33 phút trước, nancy9x đã nói:lisp của anh Duong Nhat Duy sao chép sang vẫn chuyển bằng tiếng việt được anh ạ, trong bản vẽ với lisp trên đó, anh test thử mà xem
Chắc bạn dùng font TVCN3. Bạn dùng font unicode sẽ thấy sai.
-
Vào lúc 5/9/2023 tại 11:03, TrauLy đã nói:Trước mắt cảm ơn Bác nhé.
Có cách nào sửa cỡ chữ mà khôg vào Unit ko vậy Bác
Chưa hiểu câu hỏi của bạn. bạn liên hệ zalo để hỗ trợ kịp thời nhé! 0848.998.045
-
2 giờ trước, TrauLy đã nói:Mình cũng sử dụng lisp này. Rất hay nhưng mình gặp phải 1 vấn đề là lúc mình dùng cad 2020 trên win 7 thì bình thường. Nhưng giờ mình dùng Win 10 thì nó ra kết quả là 0/0. Nhờ các Bác giúp mình khắc phục với. Thank các Bác nhiều
Chạy lisp nó hiện ra bảng thông báo vậy hả??
dùng lệnh: ATTDIA nhập số 0 nhé
-
Vừa xong, tannguyen291 đã nói:mình không hiểu ý bạn.
(defun c:testdt1 (/ pt1 sb str) (setq pt1 (getpoint ) sb (BoundaryAreaPoint pt1) str (rtos (car sb) 2 2) ) (mapcar 'vla-delete (cdr sb)) (entmake (list(cons 0 "TEXT")(cons 100 "AcDbEntity")(cons 100 "AcDbText")(cons 1 str)(cons 10 pt1)(cons 40 2)(cons 41 1)(cons 50 0))) (princ) )bạn thử đoạn test này của mình xem lỗi ở đâu
cái mày pick điểm nên nó không vấn đề gì cả
-
1 phút trước, tannguyen291 đã nói:Boundary mà bạn. làm sao mà giao nhau??
Nhầm ý mình có người nói Thay Hatch bằng Polyline. mà như trường hợp trên có 2 polyline chồng nhau nên khó làm thôi.
-
1 giờ} trướ}c, tannguyen291 đã nói:bạn thử dùng hàm này của mình xem sao thay cho hatch.
(defun BoundaryAreaPoint ( pt / ent lst area) (setq ent (entlast)) (vl-cmdf "_.boundary" "A" "I" "Y" "O" "P" "X" pt "") (while (setq ent (entnext ent)) (setq lst (cons (vlax-ename->vla-object ent) lst)) ) (setq lst (vl-sort lst '(lambda (a b) (> (vla-get-area a) (vla-get-area b)))) area (abs (apply '- (mapcar 'vla-get-area lst))) ) (cons area lst) )Nếu Polyline thì khó xét vùng giao nhau?
-
39 phút trước, DOAN NGOC BACH đã nói:Bạn tham khảo cái này nhé:
-
1 giờ} trướ}c, duongdinhdbp đã nói:Em có sưu tầm được lips đánh cao độ, đỉnh polyline ở trên mạng nhưng text ghi ở cuối hàng, nhờ các bác giúp đỡ chỉnh lại lips giúp em để giá trị text nằm ở giữa polyline. Cảm ơn các bác
code:(defun c:DSH2 (/ ent par poi ss)
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(while (and (setq ent (ssname ss 0)) (ssdel ent ss))
(setq par (vlax-curve-getEndParam ent)
poi (vlax-curve-getpointatparam ent par))
(entmake
(list (cons 0 "TEXT")
(cons 10 poi)
(cons 7 (getvar 'TEXTSTYLE))
(cons 40 (* (getvar 'DIMTXT) (getvar 'DIMSCALE)))
(cons 1 (strcat (rtos (caddr poi) 2 0) "/" (itoa (1+ (fix par)))))))))
(princ))Gửi bạn
(defun c:DSH2 (/ ent par poi ss len pt) (if (setq ss (ssget '((0 . "LWPOLYLINE")))) (while (and (setq ent (ssname ss 0)) (ssdel ent ss)) (setq par (vlax-curve-getEndParam ent) poi (vlax-curve-getpointatparam ent par)) (setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))) (setq pt (vlax-curve-getPointAtDist ent (/ len 2))) (entmake (list (cons 0 "TEXT") (cons 10 pt) (cons 7 (getvar 'TEXTSTYLE)) (cons 40 (* (getvar 'DIMTXT) (getvar 'DIMSCALE))) (cons 1 (strcat (rtos (caddr poi) 2 0) "/" (itoa (1+ (fix par))))))))) (princ))-
1
-
-
1 giờ} trướ}c, trungkaka119 đã nói:Ước gì có thể Preview trước khi in
Có bạn nhé chỗ kính lúp đó
-
13 giờ trước, abiabu9x đã nói:Lisp của anh huunhantvxdts hay nhưng chạy trên nền drawing mới thì được chứ chạy trên nền bản vẽ có sẵn thì toàn lỗi thôi, có ai sửa lisp của anh 707 như ý em muốn được không ạ? em có chèn điểm text rồi nhưng đôi lúc chữ lại trùng lên các đường line hoặc hố ga nên in ra khó nhìn ạ
1. Lỗi là do đường polyline của bạn có cao độ. 2. Do bạn pick không đúng đường Polyline
-
6 giờ trước, Minh Nghĩa đã nói:Nhờ các bác giúp em, em cảm ơn
Tham khảo cái này xem thế nào nhé
-
1
-
-
2 giờ trước, abiabu9x đã nói:Cảm ơn anh rất nhiều, lisp này đúng ý em rồi nhưng sao khi chạy lisp trên bản cad drawing mới thì lisp chạy rất tốt, nhưng khi chạy lisp trên nền bản vẽ có sẵn thì lúc được lúc không hoặc khi pick nhiều điểm nội suy lisp sẽ báo lỗi: : pick điểm nội suy error: bad aragument type:number: nil (trong khi chạy các lisp khác thì vẫn rất trơn chu). Rất mong các anh sửa lỗi giúp em! Em cảm ơn
bản vẽ của em đây:
bạn lưu ý, các đối tượng tim là đường Polyline nhé, cái nữa là đường polyline phải có Z=0
liên heei zalo để hỗ trợ kịp thời nhé: 0848.998.045
-
Vào lúc 13/11/2022 tại 20:11, abiabu9x đã nói:Yêu cầu lisp nội suy autocad theo khoảng cách ạ. Ví dụ trên 1 đường thẳng(line hoặc pline) đầu và cuối có cho số liệu text, yêu cầu pick điểm nội suy bất kỳ trên đường thẳng ạ. trên ảnh em muốn nội suy ra điểm khoanh màu hồng giữa hai điểm đã biết 2.18 và 2.36 ạ. Em xin cảm ơn mọi người giúp đỡ ạ!
Không biết có phải bạn bên diễn đàn Autolisp hỗ trợ vẽ cad không
mình có hỗ trợ bên đó rồi nên gửi lên cho bạn luôn
lisp đây nhé: https://1drv.ms/u/s!AiQ74BvGK-lKgrp897nrI9r316PUnA?e=Dvphf8
-
1
-
-
2 giờ trước, vietduc147258 đã nói:Mình có sưu tập được lisp lọc để chọn đối tượng block cùng tên rất tiện dụng. Nhưng không lọc được các block động (Dynamic Block). Đã thử QSELECT và FILTER nhưng cũng thất bại.
Mong các bác giúp em sửa lisp lọc này.
(defun c:fb ( / blockname sset); filter all blocks of same name (setq blockname (cdr (assoc 2 (entget (car (entsel)))))) (setq sset (ssget (list (cons 2 blockname)))) (sssetfirst sset sset) (princ (strcat "\nSelected " (itoa (sslength sset)) " instances of block \"" blockname "\".")) (princ) )P/S: Có lisp SelDB.vlx làm được việc này nhưng khi load lisp nó mở lên trang web cộng với chức năng tìm kiếm chuyên sâu hơn. Nên lisp dùng hơi nhiều thao tác. https://www.cadstudio.cz/dl/SelDB.vlx
Bạn xem được không nhé
(defun C:CBLM (/ ent1 ss ssblc tenblmau) (setq ent1 (car (LM:SelectIf "\nCh\U+1ECDn Block m\U+1EABu:" (lambda (x) (eq "INSERT" (cdr (assoc 0 (entget (car x))))) ) entsel nil))) (setq tenblmau (laytenblock ent1)) (princ "\nChon vung:") (setq ss (ss->lst (ssget (list (cons 0 "INSERT"))))) (setq ssblc (List-to-ss (vl-remove-if-not '(lambda (x) (= (laytenblock x) tenblmau)) ss))) (sssetfirst ssblc ssblc) (princ) ) ;;---------------------=={ Select if }==----------------------;; ;; ;; ;; Provides continuous selection prompts until either a ;; ;; predicate function is validated or a keyword is supplied. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; msg - prompt string ;; ;; pred - optional predicate function [selection list arg] ;; ;; func - selection function to invoke ;; ;; keyw - optional initget argument list ;; ;;------------------------------------------------------------;; ;; Returns: Entity selection list, keyword, or nil ;; ;;------------------------------------------------------------;; (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 List-to-ss (lst / ss) (setq ss (ssadd)) (foreach item lst (or (= (type item ) 'Ename) (setq item (vlax-vla-object->ename item))) (setq ss (ssadd item ss)) ) ss ) ;;;;;;;;;;;;;;;;; (defun laytenblock (ent / blk_name) (if (not (setq blk_name (vlax-get (vlax-Ename->Vla-Object ent) 'Effectivename))) (setq blk_name (vla-get-name (vlax-Ename->Vla-Object ent))) ) blk_name ) ;;;;;;;;;;;;;;;;;;;;;;;;; (defun ss->lst (ss / lst) (if ss (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) ) )-
1
-
1
-
-
29 phút trước, limfx đã nói:Nhờ các anh giúp khắc phục lỗi ở tham số 72, 73 của entmake text
(entmake (list
(cons 0 "TEXT")
(cons 10 p);point
(cons 40 2);hight
(cons 50 0);angle
(cons 1 text);content
(cons 72 1);middle
(cons 73 2);center
))(defun MakeText (point string Height Ang justify Style Layer Color / Lst); Ang: Radial (setq Lst (list '(0 . "TEXT") (cons 8 (if Layer Layer (getvar "Clayer"))) (cons 62 (if Color Color 256)) (cons 10 point) (cons 40 Height) (cons 1 string) (if Ang (cons 50 Ang)) (cons 7 (if Style Style (getvar "Textstyle"))) ) justify (strcase justify) ) (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point))))) ((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point))))) ((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point))))) ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3))))) ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3))))) ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3))))) ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2))))) ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2))))) ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2))))) ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1))))) ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1))))) ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))) ) (entmakex Lst) )Bạn tham khảo lisp này nhé
-
1
-
-
1 giờ} trướ}c, vuhoach đã nói:Nhìn trên video thì cũng rất tuyệt vời, nhưng máy em cad 2018 chạy báo lỗi. Ngoài ra kết quả xuất ra em muốn dưới dạng txt, csv để em có thể xử lý thêm dữ liệu. Thanks bác.
Mình cũng dùng 2018 mà. bạn export là ra file csv nhé. liên hệ Zalo: 0848.998.045 để mình hỗ trợ lỗi cho nhé
-
1
-
-
Thử lisp này xem có đúng yêu cầu không nhé:
Clip hướng dân dùng nhé:
-
1
-
-
16 phút trước, Chienluu đã nói:Em chào mọi người, e có dùng lisp để thống kê block thuộc tính chia sẻ trên diễn đàn của tác giả tên là 3Duy, e có tìm các nguồn trích dẫn nhưng không rõ tác giả là ai? a chị nào là tác giả e xin phép được kết nối e muốn trao đổi thêm. Xin chân thành cảm ơn
Nếu không liên hệ được tác giả có thể liên hệ mình hỗ trợ nhé:
Zalo: 0848.998.045
-
1
-
-
20 phút trước, vuhoach đã nói:Các bác xem file bên dưới để rõ ý hơn. Như đã nói ở trên, hiện em thấy các lisp xuất tọa độ chưa giải quyết được bài toàn xuất tọa độ đối tượng (thường là block) kèm tên của nó.
Vậy nên em chia nhỏ bài toán trên thành các bước như sau:
+ Bước 1: dùng lisp chuyển các block muốn xuất tọa độ thành các point (đã có lisp rồi)
+ Bước 2: Move tên điểm có thể dạng text vào các point đã thực hiện ở bước 1 (nếu tên điểm dạng text thì em đã có lisp đính kèm đầu topic) nhưng đa số tên điểm dưới dạng block attribute (block thuộc tính) vào các point nói trên (tương tự ảnh động bên dưới, thay vì move text, em muốn lisp mới có thể move được block vào point)
+ Xuất tọa độ text hoặc block attribute tên điểm ra excel (chính là tọa độ block ban đầu)
Bước 1 và bước 3 là em đã giải quyết được, thực ra bước 2 hoàn toàn có thể convert các attribute sang text thì bài toàn cũng đượcc giải quyết, nhưng nhiều khi bất tiện vì nếu block đó chỉ có 01 attribute thì khá dễ, nhưng nếu nó có nhiều hơn 01 attribute thì sẽ bị loạn phải mất công xử lý. Bước 2 nếu giải quyết được thì sẽ rất nhiều người sử dụng vì hiện em thấy dân thiết kế ngoài nhà thì dùng block attribute rất nhiều.
PS: nếu các bác có thể giải quyết vấn đề xuất tọa độ đối tượng kèm tên đối tượng (nằm gần) trong 1 lisp thì tốt quá, không cần phải chia nhỏ như em
1.MB chieu sang giao thong.DWG
Cái này bạn đừng quan tâm lips bạn đã có làm gì, nó là ảnh hưởng đến giải thuật người viết. cái này thì như bản vẽ của bạn quét 1 cái là nó ra kết quả bạn mong muốn luôn chứ không phải chuyển tới chuyển lui chi cả.
-
2 giờ trước, Lương Sơn đã nói:Chào các bác. Em có xin được 1 lisp pick diện tích và thay số vào text có sẵn. Nhưng khi pick diện tích thì lisp chỉ hiện đường bao các vùng mình đã pick, cảm giác rất khó nhìn. Nên em muốn nhờ các bác sửa hộ em khi pick diện tích sẽ hatch luôn vùng mình pick. Em cảm ơn ạ.
AA- pick dien tich va thay so.lsp
(defun C:AA (/ M ent ss area str C_text O_text N_text N_text1 Text olderr ) (defun SetClipText (str / html result) (if (= 'STR (type str)) (progn (setq html (vlax-create-object "htmlfile") result (vlax-invoke (vlax-get (vlax-get html 'ParentWindow) 'ClipBoardData) 'setData "Text" str)) (vlax-release-object html) str ) ) ) (defun ssnewer (ent / ss ent1) (if ent (progn (setq ent1 ent) (while (setq ent1 (entnext ent1)) (if ent1 (progn (if (NULL ss) (setq ss (ssadd))) (setq ss (ssadd ent1 ss)) ) ) ) ss ) nil ) ) (defun sleep_osnap ()(setvar "OSMODE" (logior (getvar "OSMODE") 16384))) (defun wake_osnap ()(setvar "OSMODE" (logand (getvar "OSMODE") -16385))) (defun toggle_osnap ()(setvar "OSMODE" (boole 6 (getvar "OSMODE") 16384))) (setvar "CMDECHO" 0) (setvar "DIMZIN" 0) (setq ent_1_command (entlast)) (setq olderr *error*) (setq *error* 1error) (setq ent (entlast)) (setq str "\nPick vung can tinh dien tich: ") (setq area 0.0) (sleep_osnap) (while (setq pt (getpoint str)) (Command "bhatch" pt "") (if (setq ss (ssnewer ent)) (progn (Command "Union" ss "") (Command ".Area" "o" (entlast)) (if area (setq area (abs (- (getvar "AREA") area))) (setq area (getvar "AREA")) ) (princ (strcat "\nTong dien tich: " (rtos (getvar "AREA") 2 (getvar "LUPREC")) "/ Dien tich vung vua pick: " (rtos area 2 (getvar "LUPREC")))) ) ) (setq str "\nPick vung can tinh dien tich tiep theo: ") ) (wake_osnap) (setq C_text (strcat "" (rtos (getvar "AREA") 2 (getvar "LUPREC")) "")) ;Bien can thay vao text (setq *error* olderr) (if (setq ss (ssnewer ent)) (Command ".Erase" ss "")) (setcliptext C_text) (princ "Dien tich da duoc copy vao Clipboard") ;;Thay doi noi dung text (if (setq O-Text (entsel (strcat "\nChon text de ghi dien tich: "))) (progn (setq Text (car O-Text) N-Text (cons 1 C_text)) (setq N-Text1 (subst N-Text (assoc 1 (entget Text)) (entget Text))) (entmod N-Text1) );Close Progn );Close IF (command "_change" O-Text "" "p" "c" "2" "") (princ) )Gửi bạn nhé
-
2
-
-
2 phút trước, vuhoach đã nói:Đúng rồi bác, nhưng lisp xuất tọa độ thông thường phải ghi tên điểm thủ công, hoặc đánh stt tự động nhưng stt này không khớp với tên điểm đã có. Vì vậy mà em muốn trên để công việc tự động cao hơn
Bạn phải gửi file cad của bạn lên để có cơ sở mới làm được:
-
9 giờ trước, vuhoach đã nói:Chào các bác, bài toán của mình như này: Mình cần xuất tọa độ của các block đèn kèm tên của nó. Như hình bên dưới là các cột đèn kèm tên của nó (tên đèn là block attribute), mình đã có lisp chuyển các đèn kia thành point, và lisp move text tới point (đính kèm bên dưới cho anh em nào cần). Nhưng do block tên đèn của mình bên trong gồm cả text lẫn attribute, dùng lệnh burst của cad có thể chuyển các attribute trong block thành text nhưng sau khi thực hiện lệnh này thì bị lẫn cả text cần lấy tọa độ lẫn text rác. Mình có thể xử lý, lọc được để lấy tọa độ text mong muốn nhưng rất mất công. Vì vậy mình muốn có một lisp có thể move thẳng block tới point để thao tác nhanh gọn hơn. Khi đó bài toàn xuất tọa độ đối tượng kèm tên sẽ đơn giản hơn rất nhiều: dùng 1 lisp chuyển block đèn kia thành point (mình đã có) -> dùng lisp đang nhờ các bạn viết move block tên đèn vào các point vừa tạo(hoặc chỉnh sửa lisp mình đính kèm) -> xuất tọa độ các block atrribute tên đèn (lisp này cũng đã có).
PS: lisp move text to point đính kèm là của Lee-Mac
Mình nghĩ bài toán này không khó với mẫu file như hình
-
18 giờ trước, traichoi85 đã nói:Chào các bạn.
Hiện nay mình có 1 dự án khoảng 500 lô nhà. file đã có số lô. mà mình muốn thêm trong mỗi lô là 1 block ( để mình làm block thuộc tính). nếu làm thủ công thì rất lâu, và phương án của mình thì sửa liên tục. Nên nhờ các bạn giúp dùm, nếu được các bạn có thể giúp thêm là xoay block theo hướng lô đất luôn. (có file đính kèm và video hỏi đính kèm)
file youtube: https://youtu.be/xZdQ5gw2coA
file
Bộ lisp mình đã có sẳn lệnh như này bạn nhé
đây bạn nhé: Cập nhật lisp Phân Lô - YouTube
https://www.youtube.com/watch?v=mwqQTzMN9bI
Liên hệ zalo: 0848.998.045
Nhờ sửa lisp tìm đối tượng giữa cad và excell
trong AutoLisp
Đã đăng · Trả lời báo cáo
Mình chỉnh lại cho bạn cột đầu tiên của vùng chọn nhé
Lisp này bạn lấy trên nhóm zalo Autolisp hỗ trợ vẽ cad sao không hỏi ở đó để mọi người hỗ trợ kịp thời.
;;;;;chon doi tuong theo handle tu excel (defun C:tra ( / CheckActiveCell CheckCloseApp Ename Handle ListAddress ListRowInvalid ListStringAddress NumRow NumRowEnd NumRowStart SelectionSet StringAddress StringAddressTotal VlaAppExcel VlaWorkbooks VlaRange VlaSheet) (setq CheckActiveCell (SHIE_CHECKACTIVECELL)) (setq SelectionSet (ssadd)) (if CheckActiveCell (progn (setq VlaAppExcel (vlax-get-or-create-Object "Excel.Application")) (vlax-put-property VlaAppExcel "Visible" :vlax-true) (setq VlaWorkbooks (vlax-get-property VlaAppExcel "Workbooks")) (setq CheckCloseApp (= (vla-get-count VlaWorkbooks) 0)) (setq VlaRange (vlax-get-property VlaAppExcel "Selection")) (setq VlaSheet (vlax-get-property VlaAppExcel "ActiveSheet")) (if VlaRange (progn (setq StringAddressTotal (vlax-get-property VlaRange "Address" :vlax-false :vlax-false 1 :vlax-false :vlax-false)) (setq ListStringAddress (SHIE_STRING_TO_LIST_NO_TRIM StringAddressTotal ",")) (foreach StringAddress ListStringAddress (setq ListAddress (SHIE_STRINGADDRESS_TO_LISTADDRESS StringAddress)) (setq NumRowStart (nth 1 ListAddress)) (setq Row (nth 2 ListAddress)) (setq NumRowEnd (nth 3 ListAddress)) (if (not NumRowEnd) (setq NumRowEnd NumRowStart) ) (setq NumRow NumRowStart) (while (<= NumRow NumRowEnd) (setq StringAddress (SHIE_LISTADDRESS_TO_STRINGADDRESS (list Row NumRow))) (setq VlaRange (vlax-get-property VlaSheet "Range" StringAddress)) (setq Handle (vlax-variant-value (vlax-get-property VlaRange "Text"))) (setq Ename (handent Handle)) (if Ename (setq SelectionSet (ssadd Ename SelectionSet)) (setq ListRowInvalid (cons NumRow ListRowInvalid)) ) (setq NumRow (+ NumRow 1)) ) ) (sssetfirst Nil SelectionSet) ) ) ) ) (if (= (sslength SelectionSet) 0) (alert "There is no valid data selected from excel!") ) (if ListRowInvalid (princ (strcat "\nThere is no valid data in row: " (SHIE_LIST_TO_STRING (mapcar '(lambda (x) (itoa (+ x 1))) ListRowInvalid) ","))) ) (princ) ) ------------------------------------------------------------------------------------------------------------------- (defun SHIE_CHECKACTIVECELL ( / CheckActiveCell CheckCloseApp VlaAppExcel VlaRangeActive VlaWorkbooks) (setq VlaAppExcel (vlax-get-Object "Excel.Application")) (if VlaAppExcel (progn (setq VlaRangeActive (vlax-get-property VlaAppExcel "Selection")) (if VlaRangeActive (setq CheckActiveCell T) ) (setq VlaWorkbooks (vlax-get-property VlaAppExcel "Workbooks")) (setq CheckCloseApp (= (vla-get-count VlaWorkbooks) 0)) (if CheckCloseApp (progn (vlax-invoke-method VlaAppExcel "Quit") (vlax-release-object VlaAppExcel) ) ) ) ) CheckActiveCell ) ------------------------------------------------------------------------------------------------------------------- (defun SHIE_STRINGADDRESS_TO_LISTADDRESS ( StringAddress / ListStringAddressCell ListAddress) (setq ListStringAddressCell (SHIE_STRING_TO_LIST_NEW StringAddress ":")) (setq ListAddress (apply 'append (mapcar 'SHIE_STRINGADDRESSCELL_TO_LISTADDRESSCELL ListStringAddressCell))) ListAddress ) -------------------------------------------------------------------------------------------------------------------- (defun SHIE_STRINGADDRESSCELL_TO_LISTADDRESSCELL ( StringAddressCell / Char ListAddressCell Pos PosBase PosTotal) (setq PosTotal (strlen StringAddressCell)) (setq Pos 1) (while (and (not PosBase) (<= Pos PosTotal) ) (setq Char (substr StringAddressCell Pos 1)) (if (member Char (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) (setq PosBase Pos) ) (setq Pos (+ Pos 1)) ) (setq ListAddressCell (list (SHIE_STRINGCOLUMN_TO_NUMCOLUMN (substr StringAddressCell 1 (- PosBase 1))) (- (atoi (substr StringAddressCell PosBase)) 1) ) ) ListAddressCell ) ------------------------------------------------------------------------------------------------------------------- (defun SHIE_LISTADDRESS_TO_STRINGADDRESS ( ListAddress / NumLength StringAddress) (setq NumLength (length ListAddress)) (if (= NumLength 2) (setq StringAddress (strcat (SHIE_NUMCOLUMN_TO_STRINGCOLUMN (nth 0 ListAddress)) (itoa (+ (nth 1 ListAddress) 1)) ) ) ) (if (= NumLength 4) (setq StringAddress (strcat (SHIE_NUMCOLUMN_TO_STRINGCOLUMN (nth 0 ListAddress)) (itoa (+ (nth 1 ListAddress) 1)) ":" (SHIE_NUMCOLUMN_TO_STRINGCOLUMN (nth 2 ListAddress)) (itoa (+ (nth 3 ListAddress) 1)) ) ) ) StringAddress ) -------------------------------------------------------------------------------------------------------------------- (defun SHIE_STRINGCOLUMN_TO_NUMCOLUMN ( StringColumn / Base NumColumn ListTemp) (setq Base 1) (setq ListTemp (reverse (mapcar '(lambda (x) (- x 64)) (vl-string->list StringColumn)))) (setq NumColumn 0) (foreach Temp ListTemp (setq NumColumn (+ NumColumn (* Temp Base))) (setq Base (* Base 26)) ) (setq NumColumn (- NumColumn 1)) ) -------------------------------------------------------------------------------------------------------------------- (defun SHIE_NUMCOLUMN_TO_STRINGCOLUMN ( NumColumn / NumMod StringColumn) (setq NumColumn (+ NumColumn 1)) (setq StringColumn "") (while (> NumColumn 0) (setq NumMod (rem NumColumn 26)) (setq StringColumn (strcat (if (= NumMod 0) "Z" (chr (+ NumMod 64))) StringColumn ) ) (if (= NumMod 0) (setq NumColumn (- (/ NumColumn 26) 1)) (setq NumColumn (/ NumColumn 26)) ) ) StringColumn ) ------------------------------------------------------------------------------------------------------------------- (defun SHIE_LIST_TO_STRING ( ListString Sep / StringValue) (setq StringValue (car ListString)) (foreach StringTemp (cdr ListString) (setq StringValue (strcat StringValue Sep StringTemp)) ) StringValue ) -------------------------------------------------------------------------------------------------------------------- (defun SHIE_STRING_TO_LIST_NEW (Stg Del / ListString) (setq ListString (SHIE_STRING_TO_LIST_NO_TRIM Stg Del)) (setq ListString (mapcar '(lambda (x) (vl-string-trim " " x)) ListString)) (setq ListString (mapcar '(lambda (x) (vl-string-trim "\t" x)) ListString)) ListString ) ------------------------------------------------------------------------------------------------------------------- (defun SHIE_STRING_TO_LIST_NO_TRIM (Stg Del / LenDel StgTemp Pos StgSub StgSubTemp ListString) (if Stg (progn (setq LenDel (strlen Del)) (setq StgTemp Stg) (while (setq Pos (vl-string-search Del StgTemp)) (setq StgSub (substr StgTemp 1 Pos)) (setq StgTemp (substr StgTemp (+ Pos 1 LenDel))) (setq StgSubTemp StgSub) (if (/= StgSubTemp "") (setq ListString (cons StgSub ListString)) ) ) (setq StgSub StgTemp) (setq StgSubTemp StgSub) (if (/= StgSubTemp "") (setq ListString (cons StgSub ListString)) ) (if (not ListString) (setq ListString (list Stg)) ) (setq ListString (reverse ListString)) ) ) ListString )