Đến nội dung


Hình ảnh
- - - - -

[Đã xong] Lisp gộp Hatch Pattern


  • Please log in to reply
11 replies to this topic

#1 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 14 September 2011 - 01:08 PM

Xuất phát từ topic này
http://www.cadviet.c...75
Tranh thủ giờ nghỉ trưa ketxu viết tặng mọi người cái này xài chơi (có khi chẳng dùng hoặc dùng 1 lần duy nhất ^^)
Lisp add toàn bộ Hatch Pattern trong các file PAT từ 1 thư mục (và các thư mục con) vào bảng Hatch của CAD (ghi thêm vào acad.pat và acadiso.pat), đỡ phải add thêm support Patch cho Hatch. Có thể áp dụng làm các việc tương tự. Chúc các bác ngon giấc ^^
Open Source :
(defun c:Add-Hatch( / ST:UI-Nil-Alert ST:File_GetAll Browse patFolder lstFiles isoFile iso1File pat1 pat2)
;@ Ketxu 13 - 9 - 11
; Add Hatch to Acad, Acadiso.pat

(grtext -1 "Assign Hatch Pattern Working ! @Ketxu ")

; =====================================================
; ============= Local Function ========================
; =====================================================

;| ======= ST:UI-Nil-Alert ============================
Alert if a value in LIST is Nil
Base on pBe CADTUTOR
@Ketxu 14 - 9 - 11
|;
(defun ST:UI-Nil-Alert ( msgDefault lst / x )
(if (setq x (vl-some '(lambda ( x ) (if (null (eval (car x))) (cadr x))) lst))
(alert (strcat msgDefault x))
)
)

;| ======= ST:File_GetAll =============================
Get all Files in subs Directory by match
Base on Lee Mac
@Ketxu 14 - 9 - 11
|;
(defun ST:File_GetAll ( Dir typ )
(append (mapcar '(lambda ( x ) (strcat Dir "\\" x)) (vl-directory-files Dir typ 1))
(apply 'append
(mapcar '(lambda ( x ) (ST:File_GetAll (strcat dir "\\" x) typ))
(cddr (vl-directory-files dir "*" -1))
)
)
)
)
;| ======= Browse =====================================
Get folder UI
@ Lee Mac
|;
(defun Browse ( msg dir flag / Shell Fold Self Path ) ;@Lee Mac
(vl-catch-all-apply
(function
(lambda ( / ac HWND )
(if
(setq Shell (vla-getInterfaceObject (setq ac (vlax-get-acad-object)) "Shell.Application")
HWND (vl-catch-all-apply 'vla-get-HWND (list ac))
Fold (vlax-invoke-method Shell 'BrowseForFolder (if (vl-catch-all-error-p HWND) 0 HWND) msg flag dir)
)
(setq Self (vlax-get-property Fold 'Self)
Path (vlax-get-property Self 'Path)
Path (vl-string-right-trim "\\" (vl-string-translate "/" "\\" Path))
)
)
)
)
)
(if Self (vlax-release-object Self))
(if Fold (vlax-release-object Fold))
(if Shell (vlax-release-object Shell))
Path
)
; =====================================================
; ============ Start Rountine =========================
; =====================================================
(cond
((and
(setq patFolder (Browse "Select Folder Contains PAT File : \n\t(Work With Sub Folder Also)" nil 0))
(setq lstFiles (ST:File_GetAll patFolder "*.PAT"))
(setq isoFile (open (setq pat1 (findfile "acadiso.pat")) "a"))
(setq iso1File (open (setq pat2 (findfile "acad.pat")) "a"))
)
(mapcar '(lambda(x)
(setq tmpOpen (open x "r"))
(while (setq Line (read-line tmpOpen))
(write-line Line isoFile)
(write-line Line iso1File)
)
(close tmpOpen)
)
lstFiles
)
(close isoFile)
(close iso1File)
(initget "Y N y n")
(setq ans (getkword "B\U+1EA1n c\U+00F3 mu\U+1ED1n l\U+01B0u l\U+1EA1i file PAT th\U+00EAm 1 b\U+1EA3n kh\U+00E1c ? [Y / N]"))
(cond ((= ans "Y")
(if(setq patSave (getfiled "File name to save ?" "PAT_back" "pat" 1))
(and (vl-file-copy pat1 (strcat (vl-string-right-trim ".pat" patSave) "-1.pat"))
(vl-file-copy pat2 (strcat (vl-string-right-trim ".pat" patSave) "-2.pat"))
)
)
)
)
(alert "Qu\U+00E1 tr\U+00ECnh th\U+00EAm Hatch \U+0111\U+00E3 ho\U+00E0n t\U+1EA5t.\nC\U+00E1c Hatch Pattern \U+0111\U+00E3 \U+0111\U+01B0\U+1EE3c th\U+00EAm v\U+00E0o m\U+1EE5c Other Predefined !!")
)
(T (ST:UI-Nil-Alert "Qu\U+00E1 tr\U+00ECnh th\U+00EAm Hatch Pattern b\U+1ECB l\U+1ED7i !\n"
'((patFolder "B\U+1EA1n ch\U+01B0a ch\U+1ECDn th\U+01B0 m\U+1EE5c ch\U+1EE9a file PAT")
(lstFiles "Trong th\U+01B0 m\U+1EE5c b\U+1EA1n ch\U+1ECDn (v\U+00E0 c\U+00E1c th\U+01B0 m\U+1EE5c con) kh\U+00F4ng ch\U+1EE9a file PAT n\U+00E0o")
(isoFile "Kh\U+00F4ng t\U+00ECm th\U+1EA5y file acadiso.pat")
(iso1File "Kh\U+00F4ng t\U+00ECm th\U+1EA5y file acad.pat")
)
)
)
)
)

  • 3

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#2 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 14 September 2011 - 01:28 PM

hà hà. tạm dừng viết lisp free mà vẫn post đều đều thế hả ketxu? Cái này cũng hay đấy, đỡ ngại mỗi lần fải cài lại cad.
  • 0

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#3 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 14 September 2011 - 01:33 PM

Tạm dừng tức là em không quay theo yêu cầu thôi, còn share cái gì vui vui thì vẫn share chứ ^^ Cái lisp chỉ là ví dụ, còn cái em muốn share là các hàm trong đó thôi. ^^ Khi mọi người gom đu đủ bộ hàm cho mình rồi thì viết 1 chương trình nhỏ nhỏ trở nên dễ như thổi cơm điện thôi ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#4 lp_hai

lp_hai

    biết lệnh measure

  • Members
  • PipPipPipPipPipPip
  • 456 Bài viết
Điểm đánh giá: 202 (khá)

Đã gửi 14 September 2011 - 03:45 PM

Ket nói là làm hử!
Rất tiện lợi, khỏi phải add vào support path, khỏi phải chỉnh sửa file hatch
  • 1
Hình đã gửi

#5 thichhoabinh

thichhoabinh

    biết vẽ circle

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

Đã gửi 14 September 2011 - 06:10 PM

Lisp phát huy tác dụng tốt khi có nhiều file PAT nằm trong các thư mục khác nhau (add support hết cũng mệt lắm :rolleyes: :rolleyes: ) và nhân tiện backup lại 1 file luôn :rolleyes:
  • 0

#6 khanghy

khanghy

    Chưa sử dụng CAD

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

Đã gửi 21 July 2013 - 07:51 PM

Ủa cái này quá tuyệt vời, cám ơn Ketox, em tìm mãi mà không được, may quá có cái lisp này, vì em có chương trình dùng chạy sử dụng cho Địa chất mà không biết đăng ký các PAT thế nào cả! Thanks All!


  • 0

#7 sumi

sumi

    biết lệnh array

  • Members
  • PipPipPip
  • 185 Bài viết
Điểm đánh giá: 55 (tàm tạm)

Đã gửi 22 July 2013 - 10:39 AM

Nó có yêu cầu save file .pat lại nhưng ko biết đó là file .pat trước khi gộp lại hay sau khi gộp lại vậy a? Nếu e mún tách ra lại thì phải làm sao vậy a?

thanks!


  • 0
"Xin chào bạn. Đây là tổng đài tin nhắn. Ấn phím 1 để có 1 lời khen. Phím 2 cho một lời chúc tốt đẹp. Phím 3 cho 1 nụ hôn. Phím 4 cho 1 cuộc hẹn. Nếu muốn tất cả hãy bấm số của tôi"

#8 sumi

sumi

    biết lệnh array

  • Members
  • PipPipPip
  • 185 Bài viết
Điểm đánh giá: 55 (tàm tạm)

Đã gửi 22 July 2013 - 11:09 AM

mình ladd hatch dc rồi nhưng trong số file hatch add thêm đó có 1 file hatch bị lỗi nên giờ mỗi lần hatch là nó báo lỗi, phải click "ok" khoảng 50 lần thì mới tiếp tục hatch dc. Ko biết làm sao để remove mấy file hatch đã add để trở về như cũ đây? lúc trc quên save lại file .pat rồi.

bạn nào có thể cho mình xin file "acad.pat" và file "acadiso.pat" của cad 2014 ko?

thanks!


  • 0
"Xin chào bạn. Đây là tổng đài tin nhắn. Ấn phím 1 để có 1 lời khen. Phím 2 cho một lời chúc tốt đẹp. Phím 3 cho 1 nụ hôn. Phím 4 cho 1 cuộc hẹn. Nếu muốn tất cả hãy bấm số của tôi"

#9 sumi

sumi

    biết lệnh array

  • Members
  • PipPipPip
  • 185 Bài viết
Điểm đánh giá: 55 (tàm tạm)

Đã gửi 23 July 2013 - 02:57 PM

có bạn nào giúp mình với!


  • 0
"Xin chào bạn. Đây là tổng đài tin nhắn. Ấn phím 1 để có 1 lời khen. Phím 2 cho một lời chúc tốt đẹp. Phím 3 cho 1 nụ hôn. Phím 4 cho 1 cuộc hẹn. Nếu muốn tất cả hãy bấm số của tôi"

#10 sgcq

sgcq

    Hội Hai Lúa

  • Members
  • PipPipPipPipPipPipPip
  • 1880 Bài viết
Điểm đánh giá: 692 (tốt)

Đã gửi 23 July 2013 - 03:13 PM

:D :D :D

Xả cái source 2014 ra rồi tìm nhanh hơn. 

Nếu đang ngồi canh topic thì đây:

http://www.cadviet.c...3/110802_35.rar

Mất bộ hatch thì đây:

http://www.cadviet.c...3/110802_36.rar

:D :D :D


  • 2

12728974_230210507314169_718723558582070 HỘI HAI LÚA

           fanpage: https://www.facebook.com/HoiHaiLua/

 

 

 

 

 

 


#11 sumi

sumi

    biết lệnh array

  • Members
  • PipPipPip
  • 185 Bài viết
Điểm đánh giá: 55 (tàm tạm)

Đã gửi 23 July 2013 - 04:32 PM

cảm ơn a! e  trả nó vể như cũ dc rồi.

dùng cak truyền thống cho an tâm! mấy hôm nay ko hatch dc gì cả!

Giờ kiểm tra lại thì cái hatch đó ko bị lỗi nhưng ko hiểu sao khi add hatch thì lại báo lỗi, hic...

 

P/S: làm sao thêm được hatch "BTCT" vào trong tab "other Predefined" như trong file hatch của a vậy?

thanks!


  • 0
"Xin chào bạn. Đây là tổng đài tin nhắn. Ấn phím 1 để có 1 lời khen. Phím 2 cho một lời chúc tốt đẹp. Phím 3 cho 1 nụ hôn. Phím 4 cho 1 cuộc hẹn. Nếu muốn tất cả hãy bấm số của tôi"

#12 sgcq

sgcq

    Hội Hai Lúa

  • Members
  • PipPipPipPipPipPipPip
  • 1880 Bài viết
Điểm đánh giá: 692 (tốt)

Đã gửi 23 July 2013 - 05:23 PM

:D :D :D

2 lúa cũng không biết nữa, copy+paste thôi. 

@ketxu: Chắc ket có tuyệt chiêu rồi. Nguyên đoạn code \u+************** thế kia 2 lúa dòm xong cũng thấy ************ luôn.

:D :D :D


  • 0

12728974_230210507314169_718723558582070 HỘI HAI LÚA

           fanpage: https://www.facebook.com/HoiHaiLua/