[编程交流] 使用LISP/VB帮助拉取bloc

;;;==WBLKALL.LSP=====================================================
;;;  (C) 1993, Chris Bryant (CIS 72570,1012)
;;;
;;;  This program WBLOCKs all block definitions in a drawing.
;;;  Features include:
;;;
;;;  1.  Writes the block to the current directory.
;;;
;;;  2.  Prompts user for new name if the block name is
;;;      more than 8 characters long.
;;;
;;;  3.  If a .DWG file with the same name already exists,
;;;      WBLKALL will ask permission first before overwriting.
;;;
;;;==================================================================
(prompt "\nWBLKALL.LSP - (C) 1993, Chris Bryant\nLoading ...")
;---------------------------------------------------------------------
(defun C:WBLKALL (/ EXPR CNT BLK_NAME BLK_LIST WBLOK WBLK L YN)
 (setq EXPR (getvar "expert"))
 (setvar "EXPERT" 4)
 (setq CNT 0)
 (setq BLK_NAME (cdr (assoc 2 (tblnext "BLOCK" T)))
       BLK_LIST (list BLK_NAME))
 (prompt "\nBuilding block list ...")
 (while (/= BLK_NAME nil)
   (setq BLK_NAME (cdr (assoc 2 (tblnext "BLOCK"))))
   (if (/= BLK_NAME nil)
     (setq BLK_LIST (cons BLK_NAME BLK_LIST))
   )
 )
 (prompt "\nWriting blocks .")
 (while (/= BLK_LIST nil)
   (setq WBLOK (car BLK_LIST)
         BLK_LIST (cdr BLK_LIST)
   )
   (if (/= (substr WBLOK 1 1) "*")
     (progn
       (setq CNT (1+ CNT))
       (princ ".")
       (if (> (strlen WBLOK) 
         (progn
           (setq WBLK WBLOK)
           (prompt (strcat "\nBlock name " WBLOK " is too long!"))
           (setq L T)
           (while (= L T)
             (setq WBLK (getstring
                        "\nEnter new block name, 8 characters or less: "
                        ))
             (if (or (> (strlen WBLK)  (= WBLK ""))
                   (prompt "\nInvalid response.")
                   (setq L nil)
             )
           )
           (if (/= BLK_LIST nil) (prompt "\nWriting blocks ."))
         )
         (setq WBLK WBLOK)
       )
       (if (equal (open (strcat WBLK ".DWG") "r") nil)
           (command "wblock" WBLK WBLOK)
           (progn
             (initget 1 "Yes No")
             (setq YN (getkword
                         (strcat
                           "\nFile " WBLK ".DWG exists. Replace? <Y/N> "
                         )))
             (if (equal YN "Y") (command "wblock" WBLK WBLOK))
             (prompt "\nWriting blocks .")
           )
       )
     )
   )
 )
 (setvar "EXPERT" EXPR)
 (prompt "\n ")
 (prompt "\nWBlocking complete.")
 (princ)
)
;----------------
(prompt " done.")
(princ)

2