Jump to content

how to preview a pattern?


belx

Recommended Posts

(defun c:pm()
;-------------------------
(defun parsestr->lst (str / LST POS str)
	(while (setq pos (vl-string-search "," str))
		(setq lst (cons (vl-string-left-trim " "(substr str 1 pos)) lst)
			str (substr str (+ pos 2))
			)
	)
	(if (> (strlen str) 0)
		(setq lst (cons (vl-string-left-trim " " str) lst))
	)
	(reverse lst)
)
;-------------------------
;(joinlst->str (list "1" "2" "3" "4" "5" "6"))
(defun joinlst->str (lst / LST POS str)
	(setq str "")
	(while lst
		(setq x (car lst))
		(if (setq lst(cdr lst))
			(setq str (strcat str x ","))
			(setq str (strcat str x))
		)
	)
	str
)
;-------------------------
(defun subst-index(var n lst / i)
	(setq i -1)
	(mapcar '(lambda(x) (if (= n (setq i (1+ i))) var x)) lst)
)
;-----------DELETE A ITOM--------------
;(delete-index 1 '((1 2 3) (4 5 6)(7 8 9)))
(defun delete-index(n lst / i)
	(setq i -1)
	(vl-remove-if '(lambda(x) (= (setq i (1+ i)) n)) lst)
)
;-----------INSERT A ITOM--------------
;(add-index "A" -1 '(0 1 2 3 4 5))
(defun add-index(var n lst / len i newlst)
	(setq len (length lst))
	(cond
		((< n 0)
			(setq newlst (cons var lst))
		)
		((>= n len)
			(setq newlst (reverse(cons var (reverse lst))))
		)
		(t
			(setq i -1 newlst nil)
			(foreach itom lst
				(if (= n (setq i (1+ i)))
					(setq newlst (cons itom newlst)
						newlst (cons var newlst)
					)
					(setq newlst (cons itom newlst))
				)
			)
			(setq newlst (reverse newlst))
		)
	)
	newlst
)
;-------------------------
(defun LM:editbox ( str / han )
	(and (< 0 (setq han (load_dialog "acad")))
		(new_dialog  "acad_txtedit" han)
		(set_tile    "text_edit"    str)
		(action_tile "text_edit" "(setq str $value)")
		(if (zerop (start_dialog)) (setq str nil))
	)
	(if (< 0 han) (unload_dialog han))
	str
)
;-------------------------
(defun readpatfile(file / files fn PatternList pat x fn)
	(if (and (setq files(findfile file))
			(setq fn (open  files "r"))
		)
		(progn
			(setq PatternList NIL pat nil)
			(while (setq x (read-line fn))
				(cond
					((wcmatch X "`**")
						(if pat
							(setq PatternList (cons (reverse pat) PatternList))
						)
						(setq pat nil
							pat (cons x pat)
						)
					)
					((wcmatch X "#*#*#*#*")
						(setq pat(cons x pat))
					)
					(t nil)
				)
			)
			(setq PatternList (cons (reverse pat) PatternList))
			(close fn)
		)
	)
	(reverse PatternList)
)
;-------------------------
(defun show_list(key newlist)
	(start_list key)
	(mapcar 'add_list newlist)
	(end_list)
)
;-------------------------
(defun act_open()
	(if (setq patfile(getfiled "SELECT A FILE(.PAT) TO OPEN" (get_tile "patfile") "pat" 2))
		(progn
			(setq PatternList (readpatfile patfile))
			(show_list "patnamelst" (mapcar 'car PatternList))
			(show_list "patterninfo" nil)
		)
	)
)
(defun act_save( / fn)
	(if (and (setq patfile(getfiled "SELECT A FILE(.PAT) TO SAVE" (get_tile "patfile") "pat" 2))
			(setq fn (open  patfile "w"))
		)
		(progn
			(foreach x PatternList
				(foreach y x
					(write-line y fn)
				)
				(write-line ";-----------------" fn)
			)
			(close fn)
		)
	)
)
;-----------SSGET TO PATTERN--------------

;------------getpatlinestr-------------
(defun getpatlinestr(/ patlinestr PT0 startpt angpt deltax deltay ang originx originy i ptn0 ptn1 dash)
	(if (and (setq PT0 (getpoint"\n Base point:"))
			(setq startpt(getpoint"\n Start point:"))
			(setq angpt(getpoint startpt "\n Angle:"))
			(or(setq deltax (getdist"\n deltaX<0>:"))(setq deltax 0))
			(or(setq deltay (getdist"\n deltaY<0>:"))(setq deltay 0))
		)
		(progn
			(setq ang (angtos(angle startpt angpt)0 4)
				originx (rtos(- (car startpt) (car pt0)))
				originy (rtos(- (cadr startpt) (cadr pt0)))
				patlinestr (strcat ang "," originx "," originy "," (rtos deltax) "," (rtos deltax))
				)
			(setq i 1 ptn0 startpt)
			(while (setq ptn1 (getpoint ptn0 (strcat "\n Get dash" (if (= (rem (setq i (1+ i)) 2)0) "CONTINOUS" "NONE")"distance<EXIT>:")))
				(setq dash (rtos(distance ptn0 ptn1))
					patlinestr (strcat patlinestr "," dash)
					ptn0 ptn1
					)
			)
		)
	)
	patlinestr
)
;----------DELETE PATTERN---------------
(defun act_delpattern()
	(if (and (setq patlstn(get_tile "patnamelst"))
			(setq patlstn (atoi patlstn))
		)
		(progn
			(setq PatternList (delete-index patlstn PatternList))
			(show_list "patnamelst" (mapcar 'car PatternList))
			(set_tile "patnamelst" (itoa patlstn))
		)
	)
)
;----------search pattern---------------
(defun act_searchpattern(/ searchstr)
	(if (/= (setq searchstr(get_tile "searchstr"))"")
		(progn
			(setq tempatlst (vl-remove-if-not '(lambda(x)(wcmatch (car x) (strcat"*" searchstr "*")))PatternList))
			(show_list "patnamelst" (mapcar 'car tempatlst))
			(set_tile "patnamelst" "0")
		)
	)
)
;----------ADD ONE LINE---------------
(defun act_addline()
	(if (setq patterninfon (get_tile "patterninfo"))
		(setq patterninfon (atoi patterninfon))
		(setq patterninfon (length patterninfo))
	)
	(setq patterninfo (add-index "Angle,StartX,StartY,DeltaX,DeltaY" patterninfon patterninfo))
	(show_list "patterninfo" patterninfo)
	(set_tile "patterninfo" (itoa (1+ patterninfon)))
	(act_patvauelst)
)
;----------DELETE ONE LINE---------------
(defun act_deline()
	(if (and (setq patterninfon (get_tile "patterninfo"))
			(setq patterninfon (atoi patterninfon))
			)
		(progn
			(setq patterninfo (delete-index patterninfon patterninfo))
			(show_list "patterninfo" patterninfo)
			(set_tile "patterninfo" (itoa patterninfon))
			(if patterninfo (act_patvauelst))
		)
		(alert "NEED TO SELECT A LINE.")
	)
)
;----------COPY TO recovery---------------
(defun act_copyline()
	(if (and (setq patterninfon (atoi(get_tile "patterninfo")))
			(setq patlinestr (nth patterninfon patterninfo));该行的字符串
		)
		(progn
			(setq recoverylst (reverse(cons patlinestr (reverse recoverylst))))
			(show_list "recoverylst" recoverylst)
			(set_tile "recoverylst" (itoa (1-(length recoverylst))))
		)
		(alert "NEED TO SELECT A LINE.")
	)
)
;----------recovery A LINE---------------
(defun act_recovery()
	(if (and
			(setq patterninfon (get_tile "patterninfo"))
			(setq patterninfon (atoi patterninfon))
			(setq recoverylstn (atoi(get_tile "recoverylst")))
			(setq patlinestr (nth recoverylstn recoverylst))
		)
		(progn
			(setq patterninfo (add-index patlinestr patterninfon patterninfo))
			(show_list "patterninfo" patterninfo)
			(set_tile "patterninfo" (itoa patterninfon))
		)
		(alert "Need to select a line in recovery and Selece insert position.")
	)
)
;----------DELETE A LINE IN recovery---------------
(defun act_recoverydel()
	(if (and (setq recoverylstn (get_tile "recoverylst"))
			(setq recoverylstn (atoi recoverylstn))
		)
		(progn
			(setq recoverylst (delete-index recoverylstn recoverylst))
			(show_list "recoverylst" recoverylst)
			(if recoverylstn (set_tile "recoverylst" (itoa recoverylstn)))
		)
		(alert "NEED TO SELECT A LINE.")
	)
)
;----------CLEAN recovery---------------
(defun act_recoveryclean()
	(setq recoverylst nil)
	(show_list "recoverylst" recoverylst)
)
;-------------------------
(defun act_patnamelst()
	(setq patlstn (atoi(get_tile "patnamelst"))
		patterninfo (nth patlstn PatternList)
		)
	(show_list "patterninfo" patterninfo)
	(set_tile "patterninfo" "0")
	(act_patvauelst)
)
;-------------------------
(defun act_patvauelst( / leard)
	(setq patterninfon (atoi(get_tile "patterninfo"))
		patlinestr (nth patterninfon patterninfo)
		infolst (parsestr->lst patlinestr)
		)
	(if (wcmatch patlinestr "`**")
		(progn
			(mode_tile "getinfo" 1)
			(setq leard (list "PatternName" "Description"))
			)
		(progn
			(mode_tile "getinfo" 0)
			(setq leard (list "angle" "originX" "originY" "deltaX" "deltaY" "dash1" "dash2" "dash3" "dash4" "dash5" "dash6" "dash7" "dash8" "dash9")))
	)
	(setq infolst (mapcar '(lambda(x y)(cons x y)) leard infolst))
	(show_list "infolst" (mapcar '(lambda (x) (strcat (car x)"\t= " (cdr x)))infolst))
)
;-------------------------
(defun act_infolst( / var str)
	(if (and (setq var (nth infolstn infolst))
			(setq str (LM:editbox (cdr var)))
		)
		(progn
			(setq infolst (subst-index (cons (car var) str) infolstn infolst);
				patlinestr (joinlst->str (mapcar 'cdr infolst));
				patterninfo (subst-index patlinestr patterninfon patterninfo);
				PatternList (subst-index patterninfo patlstn PatternList);
				)
			(show_list "patterninfo" patterninfo)
			(set_tile "patterninfo" (itoa patterninfon))
			(show_list "infolst" (mapcar '(lambda (x) (strcat (car x)"\t= " (cdr x)))infolst))
			(set_tile "infolst" (itoa infolstn))
		)
	)
)
;-------------------------
(defun showdcl()
	(if (and(setq dclfile(findfile "PatternModify.dcl"))
			(>= (setq DCLID (load_dialog dclfile)) 0)
		)
		(progn
			(new_dialog "pat" DCLID)
			(set_tile "patfile" patfile)
			(if PatternList (show_list "patnamelst" (mapcar 'car PatternList)))
			(if patterninfo(show_list "patterninfo" patterninfo))
			(if recoverylst(show_list "recoverylst" recoverylst))
			(if infolst(show_list "infolst" (mapcar '(lambda (x) (strcat (car x)"\t= " (cdr x)))infolst)))
			;(if dcldata (setdcldata))
			(action_tile "open" "(act_open)")
			(action_tile "save" "(act_save)")
			(action_tile "delpattern" "(act_delpattern)")
			(action_tile "searchbut" "(act_searchpattern)")
			(action_tile "addline" "(act_addline)")
			(action_tile "deline" "(act_deline)")
			(action_tile "copyline" "(act_copyline)")
			(action_tile "recovery" "(act_recovery)")
			(action_tile "recoverydel" "(act_recoverydel)")
			(action_tile "recoveryclean" "(act_recoveryclean)")
			(action_tile "patnamelst" "(act_patnamelst)")
			(action_tile "patterninfo" "(act_patvauelst)")
			(action_tile "infolst" "(setq infolstn (atoi $value)) (if(= $reason 4) (act_infolst))")
			;(action_tile "open" "(act_openpatfile)")
			(action_tile "cancel" "(done_dialog)")
			(action_tile "addpattern" "(done_dialog 11)")
			(action_tile "getinfo" "(done_dialog 12)")
			;(action_tile "accept" "(getdcldata)(done_dialog 0)")
			(setq return (start_dialog))
			(cond
				((= return 11)
					(princ)
				)
				((= return 12)
					(if (setq patlinestr (getpatlinestr))
						(setq patterninfo (add-index patlinestr patterninfon patterninfo))
					)
					(showdcl)
				)
				(t nil)
			)
		)
	)
)
;-------------------------
(if (not PatternList)
	(setq patfile (findfile "acadiso.pat")
		PatternList (readpatfile patfile )
	)
)
(showdcl)
)

 

;----------------------

/*★★★★★ListDCL @ fsxm.mjtd.com★★★★★*/

pat:dialog {
   label = "Pattern Modify" ;
   :row {
       :button {
					key = "open" ;
           fixed_width = true ;
           label = "Open" ;
       }
       :button {
           fixed_width = true ;
					key = "save" ;
           label = "Save" ;
       }
       :edit_box {
			    key = "patfile" ;
           width = 100 ;
       }
       :button {
           fixed_width = true ;
					key = "help" ;
           label = "Help" ;
       }
       :button {
           fixed_width = true ;
           is_cancel = true ;
           label = "Cancel" ;
       }
   }
   :row {
       :boxed_column {
           label = "Pattern List" ;
           children_fixed_height = true ;
           :row {
               fixed_height = true ;
               :button {
                   fixed_width = true ;
									key = "addpattern" ;
                   label = "Add Pattern" ;
               }
               :button {
                   fixed_width = true ;
									key = "delpattern" ;
                   label = "Delete Pattern" ;
               }
           }
           :row {
               fixed_height = true ;
               :edit_box {
                   key = "searchstr" ;
               }
               :button {
                   key = "searchbut" ;
                   fixed_width = true ;
                   label = "Search" ;
               }
           }
           :list_box {
               height = 35 ;
               key = "patnamelst" ;
               width = 30 ;
           }
       }
       :boxed_column {
           children_fixed_height = true ;
           label = "Pattern Info" ;
           :row {
               fixed_height = true ;
               :button {
                   fixed_width = true ;
									key = "addline" ;
                   label = "Add Line" ;
               }
               :button {
                   fixed_width = true ;
									key = "deline" ;
                   label = "Dele Line" ;
               }
               :button {
                   fixed_width = true ;
									key = "copyline" ;
                   label = "Copy to Recovery" ;
               }
           }
           :list_box {
               key = "patterninfo" ;
               width = 45 ;
               height = 24 ;
           }
           :image {
               key = "img" ;
							aspect_ratio = 0.6 ;
               color = -2 ;
               width = 45 ;
           }
       }
       :column {
           :boxed_column {
               label = "Recovery" ;
               :row {
                   fixed_height = true ;
                   :button {
                       fixed_width = true ;
											key = "recovery" ;
                       label = "Recovery Line" ;
                   }
                   :button {
                       fixed_width = true ;
											key = "recoverydel" ;
                       label = "Delete Line" ;
                   }
                   :button {
                       fixed_width = true ;
											key = "recoveryclean" ;
                       label = "Clean" ;
                   }
               }
               :list_box {
                   key = "recoverylst" ;
									fixed_height = true ;
               }
           }
           :boxed_column {
               children_alignment = centered ;
               label = "Modify line info" ;
							:button {
                   fixed_width = true ;
									key = "getinfo" ;
                   label = "Get Line Info" ;
               }
               :list_box {
                   key = "infolst" ;
									tabs = "10" ;
									height = 23 ;
               }
           }
       }
   }
}

Link to comment
Share on other sites

I appreciate language difference but "HELP" has details on what the Pat file details mean. Will try to find I have old paper copies so useful quicker to find stuff like this but at work.

 

https://knowledge.autodesk.com/support/autocad/troubleshooting/caas/sfdcarticles/sfdcarticles/Creating-new-Custom-Hatch-patterns.html

 

There may be a lisp that checks a pat file by trying to draw it I would suggest before adding to say acad.pat its been a while pretty sure can load custom.pat etc

Link to comment
Share on other sites

@belx:

DCL is limited. There is no special tile for this purpose. But you can use the vector_image function to draw vectors in a DCL image tile. Displaying a hatch pattern should therefore be possible. It will require some work though.

 

It may be worth looking at OpenDCL, which does have a Hatch control.

Link to comment
Share on other sites

  • 3 weeks later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...