;;; TORVA LISP - Block Solid Fill (torva.kr/lisp.html)
;;; BHT : selected blocks get a SOLID hatch over every closed outline inside them.
;;;       The hatch is a separate object (not inside the block, not associative),
;;;       one hatch per closed outline. The block itself is not changed.
;;; Layer : BLOCK-FILL (color 4), made if missing
;;; Skipped : xrefs, blocks on locked layers, blocks whose outlines are not closed
;;; Gap tolerance while hatching = 0.1 x DIMSCALE (10 at 1:100)

(vl-load-com)

(defun tv-bht-layer ()
  (if (not (tblsearch "LAYER" "BLOCK-FILL"))
    (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord")
               (2 . "BLOCK-FILL") (70 . 0) (62 . 4) (6 . "Continuous")))))

(defun tv-bht-locked (e)
  (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 (entget e)))))))))

(defun tv-bht-xref (e)
  (= 4 (logand 4 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget e)))))))))

;; one block -> hatches. Returns number of hatches made, nil = failed
;; vla Explode leaves the block as it is and returns the pieces
(defun tv-bht-fill (e / pieces bnd last r n en)
  (setq pieces (vl-catch-all-apply 'vlax-invoke (list (vlax-ename->vla-object e) 'Explode)))
  (if (not (vl-catch-all-error-p pieces))
    (progn
      (setq bnd (ssadd))
      (foreach o pieces
        (if (member (vla-get-ObjectName o)
                    '("AcDbLine" "AcDbPolyline" "AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbSpline"))
          (ssadd (vlax-vla-object->ename o) bnd)))
      (setq last (entlast) n 0)
      (if (> (sslength bnd) 0)
        (setq r (vl-catch-all-apply 'vl-cmdf (list "_.-HATCH" "_P" "SOLID" "_S" bnd "" ""))))
      (foreach o pieces (vl-catch-all-apply 'vla-Delete (list o)))
      (setq en last)
      (while (setq en (if en (entnext en) (entnext)))
        (if (= (cdr (assoc 0 (entget en))) "HATCH")
          (progn
            (vl-cmdf "_.CHPROP" en "" "_LA" "BLOCK-FILL" "_C" "_BYLAYER" "")
            (setq n (1+ n)))))
      (if (> n 0) n))))

(defun c:BHT (/ *error* old vars ss i e k n tot skip fail)
  (setq old *error*
        vars (list (cons "CMDECHO" (getvar "CMDECHO")) (cons "HPASSOC" (getvar "HPASSOC"))
                   (cons "HPSEPARATE" (getvar "HPSEPARATE")) (cons "HPGAPTOL" (getvar "HPGAPTOL"))))
  (defun *error* (msg)
    (foreach v vars (setvar (car v) (cdr v)))
    (command "_.UNDO" "_E")
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (princ "\nºí·Ï ¼±ÅÃ: ")
  (if (setq ss (ssget '((0 . "INSERT"))))
    (progn
      (setvar "CMDECHO" 0)
      (command "_.UNDO" "_BE")
      (setvar "HPASSOC" 0)
      (setvar "HPSEPARATE" 1)
      (setvar "HPGAPTOL" (min 5000.0 (* 0.1 (max 1.0 (getvar "DIMSCALE")))))
      (tv-bht-layer)
      (setq i 0 n 0 tot 0 skip 0 fail 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (cond ((or (tv-bht-locked e) (tv-bht-xref e)) (setq skip (1+ skip)))
              ((setq k (tv-bht-fill e)) (setq n (1+ n) tot (+ tot k)))
              (T (setq fail (1+ fail)))))
      (command "_.UNDO" "_E")
      (foreach v vars (setvar (car v) (cdr v)))
      (princ (strcat "\n" (itoa n) " block(s) filled, " (itoa tot) " hatch(es)"
                     (if (> fail 0) (strcat ", outline not closed " (itoa fail)) "")
                     (if (> skip 0) (strcat ", locked layer or xref, skipped " (itoa skip)) "")))))
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Block Solid Fill: BHT | torva.kr")
(princ)

;;; ---- TVKEY: change a shortcut - shared by every TORVA LISP (torva.kr/lisp.html) ----
;;; TVKEY -> command -> new shortcut. The original command keeps working
;;; Shortcuts are saved on this PC as TORVA-KEYS and restored whenever a TORVA LISP loads
;;; (Every TORVA LISP carries this block; loading several just redefines the same functions)

;; "A1=PY;B2=CN;" -> (("A1" . "PY") ("B2" . "CN"))
(defun tv-key-list (/ s i out)
  (setq s (cond ((getenv "TORVA-KEYS")) ("")) out nil)
  (while (setq i (vl-string-search ";" s))
    (setq out (cons (substr s 1 i) out) s (substr s (+ i 2))))
  (if (/= s "") (setq out (cons s out)))
  (vl-remove nil
    (mapcar '(lambda (x / j) (if (setq j (vl-string-search "=" x)) (cons (substr x 1 j) (substr x (+ j 2)))))
            (reverse out))))

(defun tv-key-save (lst)
  (setenv "TORVA-KEYS" (apply 'strcat (mapcar '(lambda (p) (strcat (car p) "=" (cdr p) ";")) lst))))

;; is cmd a loaded LISP command
(defun tv-key-cmd-p (cmd)
  (member (type (eval (read (strcat "C:" cmd)))) '(SUBR USUBR EXRXSUBR)))

(defun tv-key-def (key cmd)
  (eval (list 'defun (read (strcat "C:" key)) '() (list (read (strcat "C:" cmd))) '(princ))))

;; is key an alias in acad.pgp ("L,   *LINE")
(defun tv-key-pgp-p (key / f h l hit)
  (if (setq f (findfile "acad.pgp"))
    (progn
      (setq h (open f "r"))
      (while (and (not hit) (setq l (read-line h)))
        (if (and (not (wcmatch l ";*")) (wcmatch (strcase l) (strcat key ",*"))) (setq hit T)))
      (close h)))
  hit)

;; reason the key cannot be used, nil if fine
(defun tv-key-bad (key lst)
  (cond
    ((not (vl-every '(lambda (c) (or (<= 48 c 57) (<= 65 c 90))) (vl-string->list key))) "¿µ¹®¡¤¼ýÀÚ¸¸")
    ((getcname key) "AutoCAD ¸í·É À̸§")
    ((tv-key-pgp-p key) "acad.pgp º°Äª°ú °°À½")
    ((and (tv-key-cmd-p key) (not (assoc key lst))) "ÀÌ¹Ì ÀÖ´Â ¸®½À ¸í·É")))

;; "My shortcuts" lines at the end of the file: (tv-my-key "A1" "BN"). Bad key -> reason only
(defun tv-my-key (key cmd / why)
  (setq key (strcase key) cmd (strcase cmd))
  (cond ((not (tv-key-cmd-p cmd)))
        ((setq why (tv-key-bad key (list (cons key cmd)))) (princ (strcat "\nShortcut " key ": " why)))
        (T (tv-key-def key cmd))))

(defun c:TVKEY (/ cmd key lst why)
  (setq lst (tv-key-list)
        cmd (strcase (getstring "\n´ÜÃàÅ°¸¦ ºÙÀÏ ¸í·É [¸ñ·Ï(?)]: ")))
  (cond
    ((= cmd ""))
    ((= cmd "?")
     (if lst
       (foreach p lst (princ (strcat "\n  " (car p) " = " (cdr p))))
       (princ "\nNo shortcuts set")))
    ((not (tv-key-cmd-p cmd)) (princ (strcat "\n" cmd " is not a loaded LISP command")))
    (T
     (setq key (strcase (getstring (strcat "\n" cmd " ÀÇ »õ ´ÜÃàÅ° [Áö¿ì±â(-)]: "))))
     (cond
       ((= key ""))
       ((= key "-")
        (foreach p lst
          (if (= (cdr p) cmd) (set (read (strcat "C:" (car p))) nil)))
        (tv-key-save (vl-remove-if '(lambda (p) (= (cdr p) cmd)) lst))
        (princ (strcat "\nShortcut for " cmd " removed")))
       ((= key cmd))
       ((setq why (tv-key-bad key lst)) (princ (strcat "\n" key ": " why)))
       (T
        (tv-key-save (cons (cons key cmd) (vl-remove-if '(lambda (p) (= (car p) key)) lst)))
        (tv-key-def key cmd)
        (princ (strcat "\n" key " now runs " cmd))))))
  (princ))

;; on load: restore saved shortcuts whose command is loaded
(foreach p (tv-key-list)
  (if (tv-key-cmd-p (cdr p)) (tv-key-def (car p) (cdr p))))
(princ "\nTVKEY: change a shortcut | torva.kr")
(princ)

;;; ---- My shortcuts: lines set at torva.kr download land below. Edit or add lines to change them ----