|
|
[code];;; AUTHOR http://www.theswamp.org/index.php?topic=47058.45
;;; Ron Perez ( ronjonp )
;;; Updated original code posted to Cadalyst http://cadtips.cadalyst.com/2d-operations/create-custom-linetype
;;; 05.13.2014 Added DCL and rewrote most of the code
;;; 05.20.2014 Added better input error trapping and some recommendations @ TheSwamp
;;; http://www.theswamp.org/index.php?topic=47058.msg520876#msg520876
;;; 05.23.2014 Put current layer at top of list per AlanJT
;;; 07.01.2014 Added a filter for layer names and different dash types
;;; 11.23.2016 Changed how text is placed within gap ( using equal gaps & modifying X offset ) so text on curves lines up better
;;; https://www.theswamp.org/index.php?topic=52299.msg572750#msg572750 Thanks for the feedback Roy!
;;; 01.18.2017 Added vertical text offset ( Top Middle Bottom )
;;; 01.18.2017 Added dropdown of extended characters dubbed 'funky chars'
;;; 04.16.2020 Added a line to add a custom description
;;; 05.12.2020 Added upright text to definition if a TTF font is used
(defun c:makelt (/ *error* _dcl _showlt _readreg _writereg _get
rjp-txtwdth _rtos _foo _getnumber _filterstrings
_addlist _ltdesc ch dashlength dashtype desc dt
e exprt fchars file filter flayers fltr
f fn g go i id layers
ltdef ltdesc ltname ltypes plays regkey strw
textgap textheight textstring textyoffset tmp toffset
tstyles txtstyle x
)
(defun _dcl (filename / file)
(if (findfile filename)
filename
(cond
((and (eq 'str (type filename)) (setq file (open filename "w")))
(foreach line
'("//04.16.2020"
"//Copyright?2014 Ron Perez (ronperez ( AT ) gmail.com)"
"b1 : button { width = 35; fixed_width = true; alignment = centered; }"
"eb : edit_box { edit_width = 15; }"
"MakeLT : dialog"
"{"
" label = \"M a k e L T by RJP\"; spacer;"
" : row"
" {"
" : boxed_column"
" {"
" label = \"- L i n e t y p e O p t i o n s -\";"
" : column"
" {"
" : eb"
" {"
" key = \"LtDef\"; label = \"L i n e t y p e N a m e\";"
" }"
" : eb"
" {"
" key = \"Desc\"; label = \"L i n e t y p e D e s c r i p t i o n\";"
" }"
" : eb"
" {"
" key = \"TextString\"; label = \"T e x t S t r i n g\";"
" }"
" : eb"
" {"
" key = \"DashLength\"; label = \"D a s h L e n g t h\";"
" }"
" : eb"
" {"
" key = \"TextHeight\"; label = \"T e x t H e i g h t\";"
" }"
" : eb"
" {"
" key = \"TextGap\"; label = \"T e x t G a p\";"
" }"
" }"
" spacer;"
" : popup_list"
" {"
" key = \"TextYOffset\"; label = \"T e x t V e r t i c a l O f f s e t\"; edit_width = 14;"
" }"
" : popup_list"
" {"
" key = \"TextStyles\"; label = \"T e x t S t y l e\"; edit_width = 14;"
" }"
" : popup_list"
" {"
" key = \"DashType\"; label = \"D a s h T y p e\"; edit_width = 14;"
" }"
" : popup_list"
" {"
" key = \"fchars\"; label = \"F u n k y C h a r s\"; edit_width = 14;"
" }"
" spacer;"
" }"
" : boxed_column"
" {"
" label = \"- A p p l y t o L a y e r ( s ) -\";"
" : list_box"
" {"
" key = \"Layers\"; width = 20; multiple_select = true;"
" }"
" : column"
" {"
" label = \"L a y e r N a m e F i l t e r\";"
" : edit_box"
" {"
" key = \"LayerFilter\"; width = 20;"
" }"
" }"
" }"
" }"
" spacer;"
" : row"
" {"
" alignment = centered;"
" : b1"
" {"
" key = \"DoIt\"; is_default = true; label = \" - C r e a t e L i n e t y p e - \";"
" }"
" : b1"
" {"
" key = \"Cancel\"; is_cancel = true; label = \"- C a n c e l -\";"
" }"
" }"
" errtile;"
"}"
)
(write-line line file)
)
(close file)
filename
)
)
)
)
(defun *error* (msg)
(and id (unload_dialog id))
(and exprt (setvar 'expert exprt))
(and file (vl-file-delete file))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _readreg (folder keyname value / regpath)
(setq regpath (strcat "HKEY_CURRENT_USER\\Software\\" folder))
(if (not (vl-registry-read regpath keyname))
(vl-registry-write regpath keyname value)
(vl-registry-read regpath keyname)
)
)
(defun _writereg (folder keyname value / regpath)
(setq regpath (strcat "HKEY_CURRENT_USER\\Software\\" folder))
(vl-registry-write regpath keyname value)
)
(defun _get (item / out)
(vlax-for x (vlax-get (vla-get-activedocument (vlax-get-acad-object)) item)
(setq out (cons x out))
)
out
)
(defun rjp-txtwdth (text height style / d e i pts)
;; Check if style has a width other than 1 otherwise gap is incorrect
(if (and (setq e (tblobjname "style" style)) (setq i (cdr (assoc 41 (entget e)))))
(setq i (/ 1. i))
(setq i 1.)
)
;;Returns textstring width, gap from insertion point to start of text, and height
(if (setq pts (textbox (list (cons 1 text) (cons 7 style) (cons 40 height))))
(progn (setq d (* i (distance (car pts) (list (caadr pts) (cadar pts)))))
(list d (caar pts) (- (cadadr pts) (abs (cadar pts))))
)
)
)
(defun _foo (string / e)
(cond ((= "" string)
(mode_tile "LtDef" 2)
(set_tile "error" (strcat "Linetype Name Cannot Be Empty!"))
)
((null (snvalid string))
(mode_tile "LtDef" 2)
(set_tile "error" (strcat "Invalid Characters Found in Linetype Name '" string "'!"))
)
((null (tblobjname "ltype" string))
(set_tile "error" (strcat "Linetype '" string "' " (_showlt) " will be CREATED..."))
)
((setq e (tblobjname "ltype" string))
(set_tile "error" (strcat "Linetype '" string "' " (_showlt) " will be REDEFINED..."))
)
((set_tile "error" (_showlt)))
)
)
(defun _showlt (/ msg txt dt)
(if (and (setq txt (get_tile "TextString"))
(setq dt (get_tile "DashType"))
(setq dt (cadr (nth (read dt) ltypes)))
(setq dt (apply 'strcat (_ltdesc dt)))
)
(strcat dt txt dt txt dt txt dt)
"Cannot Display Linetype!"
)
)
(defun _rtos (real) (vl-prin1-to-string real))
(defun _getnumber (key default)
(cond ((<= (atof (get_tile key)) 0.0)
(set_tile "error" "Invalid Data! Using Last Value...")
(set_tile key default)
)
((wcmatch (get_tile key) ".*") (set_tile key (strcat "0" (get_tile key))))
((_showlt) (vl-princ-to-string (atof (get_tile key))))
)
)
(defun _filterstrings (listofstrings filter / out)
(if (setq out (vl-remove-if-not
(function (lambda (x) (wcmatch (strcase x) (strcase filter))))
listofstrings
)
)
(progn (mode_tile "Layers" 0) out)
(progn (mode_tile "Layers" 1) '("Nothing Matches Filter!"))
)
)
;; (_filterstrings layers "~*|*")
(defun _addlist (key l) (start_list key) (mapcar 'add_list l) (end_list))
(defun _ltdesc (l / tmp)
(mapcar '(lambda (x)
(cond ((zerop x) ".")
((minusp x)
(setq tmp "")
(repeat (if (zerop (fix x))
1
(fix (* 10. (abs x)))
)
(setq tmp (strcat tmp " "))
)
)
((<= x 0.1) "-")
((setq tmp "") (repeat (fix (* 10. x)) (setq tmp (strcat tmp "-"))))
)
)
l
)
)
;; (apply 'strcat (_ltdesc '(0 -0.25 0 -0.25 0 -0.25 0 -0.25 0)))
(cond
((not (setq fn (_dcl (strcat (getenv "temp") "\\MakeLT_04.16.2020.dcl"))))
(princ "\nDialog could not be created!")
)
((null (setq id (load_dialog fn))) (princ "\nDialogue created but could not be loaded!"))
((setq regkey "MakeLT")
(setq tstyles (vl-remove-if
'(lambda (x) (wcmatch x "*|*"))
(acad_strlsort (mapcar 'vla-get-name (_get "textstyles")))
)
)
(setq toffset '("Top" "Middle" "Bottom"))
(setq i 127)
(repeat 128 (setq fchars (cons (chr (setq i (1+ i))) fchars)))
(setq fchars (reverse fchars))
(setq layers (acad_strlsort (mapcar 'vla-get-name (_get "layers"))))
;; Append current clayer to top of list
(setq layers (cons (getvar 'clayer) (vl-remove (getvar 'clayer) layers)))
;; Percentage of dashlength, each sublist should add up to 1 and not exceed 10 entries
;; Positive entries are dashes, negative entries are gaps
(setq ltypes (list (list "Continuous" '(1.0))
(list "Center" '(0.35 -0.10 0.10 -0.10 0.35))
(list "Dashdot" '(0.35 -0.15 0 -0.15 0.35))
(list "Dashdot2" '(0.2 -0.1 0 -0.1 0.2 -0.1 0 -0.1 0.2))
(list "Dashed" '(0.3 -0.1 0.3 -0.1 0.3))
(list "Dashed2" '(0.25 -0.125 0.25 -0.125 0.25))
(list "Dot" '(0 -0.25 0 -0.25 0 -0.25 0 -0.25 0))
(list "Hidden" '(0.2 -0.2 0.2 -0.2 0.2))
(list "Hidden2" '(0.143 -0.143 0.143 -0.143 0.143 -0.143 0.143))
(list "Phantom" '(0.3 -0.08 0.08 -0.08 0.08 -0.08 0.3))
(list "3Dash" '(0.325 -0.05 0.05 -0.05 0.05 -0.05 0.05 -0.05 0.325))
(list "2Dots" '(0.35 -0.10 0 -0.10 0 -0.10 0.35))
(list "3Dots" '(0.3 -0.10 0 -0.10 0 -0.10 0 -0.10 0.3))
)
)
;; (mapcar '(lambda (x) (apply '+ (mapcar 'abs x)))(mapcar 'cadr ltypes))
;; Setq defaults based on metric vs imperial
(mapcar 'set
'(dashlength textheight textgap)
(if (= 0 (getvar 'measurement))
'("0.25" "0.075" "0.025")
'("12.5" "2.5" "0.65")
)
)
(new_dialog "MakeLT" id)
(_addlist "TextStyles" tstyles)
(_addlist "DashType" (mapcar 'car ltypes))
(_addlist "TextYOffset" toffset)
(_addlist "fchars" fchars)
;; Set values
(setq ch (_readreg regkey "TextStyles" "0"))
(set_tile "TextStyles"
(cond ((nth (read ch) tstyles) ch)
((setq ch "0"))
)
)
(set_tile "DashType" (setq dashtype (_readreg regkey "DashType" "0")))
(set_tile "TextYOffset" (setq textyoffset (_readreg regkey "TextYOffset" "1")))
(set_tile "TextString" (setq textstring (_readreg regkey "TextString" "X")))
(set_tile "LtDef" (setq ltdef (_readreg regkey "LtDef" "X")))
(set_tile "Desc" (setq desc (_readreg regkey "Desc" (getenv "username"))))
(set_tile "DashLength" (setq dashlength (_readreg regkey "DashLength" dashlength)))
(set_tile "TextHeight" (setq textheight (_readreg regkey "TextHeight" textheight)))
(set_tile "TextGap" (setq textgap (_readreg regkey "TextGap" textgap)))
(set_tile "LayerFilter" (setq fltr (_readreg regkey "LayerFilter" "~*|*")))
(_addlist "Layers" (setq flayers (_filterstrings layers fltr)))
(_foo ltdef)
;; Update values on change
(action_tile "Layers" "(setq plays $value)")
(action_tile "TextYOffset" "(setq TextYOffset $value)")
(action_tile "TextStyles" "(setq ch $value)")
(action_tile
"fchars"
"(setq TextString (strcat TextString (nth (atoi $value)fchars)))(set_tile \"TextString\" TextString)(_foo ltdef)"
)
(action_tile "Desc" "(setq desc $value)")
(action_tile "DashType" "(setq dashtype $value)(_foo ltdef)")
(action_tile "LtDef" "(setq ltdef $value) (_foo ltdef)")
(action_tile "TextString" "(setq TextString $value) (_foo ltdef)")
(action_tile "DashLength" "(setq DashLength (_getnumber \"DashLength\" DashLength))")
(action_tile "TextHeight" "(setq TextHeight (_getnumber \"TextHeight\" TextHeight))")
(action_tile "TextGap" "(setq TextGap (_getnumber \"TextGap\" TextGap))")
(action_tile "DoIt" "(setq go T) (_foo ltdef) (setq ltdesc (_showlt)) (done_dialog 1)")
(action_tile
"LayerFilter"
"(setq fltr $value)(setq flayers (_filterstrings layers fltr))(_addlist \"Layers\" flayers))"
)
(action_tile "Cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog id)
(if go
(progn
;; Write defaults to registry
(_writereg regkey "TextStyles" ch)
(_writereg regkey "TextYOffset" textyoffset)
(_writereg regkey "DashType" dashtype)
(_writereg regkey "LtDef" ltdef)
(_writereg regkey "Desc" desc)
(_writereg regkey "TextString" textstring)
(_writereg regkey "DashLength" dashlength)
(_writereg regkey "TextHeight" textheight)
(_writereg regkey "TextGap" textgap)
(_writereg regkey "LayerFilter" fltr)
(setq txtstyle (nth (read ch) tstyles))
(setq ltname ltdef)
;; Check for TTF to set upright flag ... bug when used with SHX
(setq f (wcmatch (strcase (cdr (assoc 3 (entget (tblobjname "Style" txtstyle))))) "*.TTF"))
(if
(and
(setq strw (rjp-txtwdth textstring (atof textheight) txtstyle))
(setq file (strcat (getenv "temp") "\\_tempmakelt_" (rtos (getvar 'date) 2 10) ".lin"))
(setq fn (open file "w"))
(setq exprt (getvar 'expert))
(setq dt (cadr (nth (read dashtype) ltypes)))
(setq textgap (atof textgap))
(setq dashtype (mapcar '(lambda (x) (strcat (_rtos (* (atof dashlength) x)) ",")) dt))
)
(progn (setq ltdef (strcat "\n*"
ltdef
","
desc
(chr 187)
" "
ltdesc
"\nA,"
(apply 'strcat dashtype)
"-"
;; 1/2 string width + text gap
(_rtos (+ textgap (setq g (* (car strw) 0.5))))
",[\""
textstring
"\","
txtstyle
",S="
textheight
(if f
",U=0"
",R=0"
)
",X=-"
(_rtos (* (+ (car strw) (* 2. (cadr strw))) 0.5))
",Y="
(cond ((= "0" textyoffset) (_rtos (- (caddr strw))))
((= "1" textyoffset) (_rtos (- (* (caddr strw) 0.5))))
((= "2" textyoffset) "0.0")
)
"],-"
;; 1/2 string width + text gap
(_rtos (+ textgap g))
)
)
(write-line ltdef fn)
(close fn)
(setvar 'expert 5)
(command "._-linetype" "load" "*" file "")
(princ (strcat ltdef "\n"))
(setvar 'expert exprt)
(vl-file-delete file)
)
)
(if (and plays (tblobjname "ltype" ltname))
(foreach i (read (strcat "(" plays ")"))
(if (and (nth i flayers) (setq e (tblobjname "layer" (nth i flayers))))
(vla-put-linetype (vlax-ename->vla-object e) ltname)
)
)
)
(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acallviewports)
)
)
)
)
(princ)
)[/code] |
|
发表于 2024-6-22 09:46:18
发表于 2024-8-6 10:42:43
