[分享]鎖圖

;;鎖圖
;;每5個圖元建立1個多重匿名圖塊
;;一半MINSERT轉到"Defpoints"層===>不能印圖
;;以上跑2次,最後再建成多重匿名圖塊
;;但對會編程的人,一點用都沒有,所以先炸開是基本功
;;保護智慧財產
https://www.autocad-tw.com/t131-topic?highlight=%E4%BF%9D%E8%AD%B7
;;低版本利用WMFOUT,WMFIN炸開圖檔
https://www.autocad-tw.com/t24947-topic
;;BY LUCAS_LAI

代碼:


(vl-load-com)
(defun C:QMBLK1 (/ A AA AAA AAL BLKS
 HOLDCLAYER HOLDECHO ;HOLDDIA HOLDREQ
 N OBJ QQ STIME ETIME
 )

  (defun DO_IT ()
    ;;慢速(因為使用了COMMAND建BLOCK),用VLISP建BLOCK同COMMAND,ENTMAKE建BLOCK(快4倍)
    (command "_.BLOCK" A "NON" '(0 0 0) AAA "")
    (setq OBJ (vla-item BLKS A))
    (vla-put-name OBJ "*U")
    (entmake (list '(0 . "INSERT")
   '(100 . "AcDbMInsertBlock")
   (cons 2 (vla-get-name OBJ))
   (cons 10 (trans '(0 0 0) 1 0))
   '(70 . 1)
   '(71 . 1)
     )
    )
  )

  (setq HOLDECHO (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command "_.undo" "_group")
  (setq STIME (getvar "date"))
  (setvar 'QAFLAGS 0)
  ;;(setq HOLDDIA (getvar "ATTDIA"))
  ;;(setq HOLDREQ (getvar "ATTREQ"))
  (setq HOLDCLAYER (getvar "CLAYER"))
  (command "_.layer" "m" "Defpoints" "c" "7" "" "lt" "CONTINUOUS" "" "")
  (setvar "CLAYER" "0")
  (setq BLKS (vla-get-blocks
       (vla-get-activedocument (vlax-get-acad-object))
     )
  )
  ;;(setvar "ATTDIA" 0)
  ;;(setvar "ATTREQ" 0)
  (setq A (rtos (* (getvar "CDATE") 1E8)))
  ;;可多跑幾次,但太多次出圖就看不到東西
  ;;1次沒法達到不能印圖
  ;;至少2次才能達到不能印圖
  (repeat 2
    (if (setq AA (ssget "_X"
 (list '(0 . "~VIEWPORT")
      '(0 . "~ATTDEF")
      (cons 410 (getvar "CTAB"))
 )
 )
 )
      (progn
 (setq AAL (sslength AA))
 (setq N 0)
 (while (> AAL N)
  (setq AAA (ssadd))
  (repeat 5
    (if (ssname AA N)
      (ssadd (ssname AA N) AAA)
    )
    (setq N (1+ N))
  )
  (DO_IT)
  (if (= (rem N 2) 1)
    (progn
      (setq QQ (entget (entlast)))
      (setq QQ (subst '(8 . "Defpoints") (assoc 8 QQ) QQ))
      (entmod QQ)
    )
  )
 )
      )
    )
  )
  (setq AAA (ssget "_X"
   (list '(0 . "~VIEWPORT")
 '(0 . "~ATTDEF")
 (cons 410 (getvar "CTAB"))
   )
    )
  )
  (DO_IT)
  ;;(setvar "ATTDIA" HOLDDIA)
  ;;(setvar "ATTREQ" HOLDREQ)
  (setq ETIME (getvar "date"))
  (prompt
    (strcat
      "\n程式共耗用時間: "
      (rtos (* 86400.0 (- (- ETIME STIME) (fix (- ETIME STIME))))
    2
    3
      )
      "秒"
    )
  )
  (setvar "CLAYER" HOLDCLAYER)
  (vlax-release-object BLKS)
  (command "_.undo" "_end")
  (setvar "cmdecho" HOLDECHO)
  (princ)
)
(princ
  "\nType QMBLK1  COMMAND建圖塊鎖圖,BY LUCAS_LAI"
)
(princ)



QMBLK1.LSP下載
[回覆可見]

感謝分享，希望可以解決問題保護智慧財產權

所以還是有可能會被破解或炸開…
看來最好還是只提供pdf檔！！

感謝大大無私地分享...感恩

感謝分享