LISP. Открытие файлов WORD, EXCEL и других типов из папки активного DWG-чертежа (Страница 2 из 2)

;|=======================================
Открытие различных типов файлов из папки активного DWG-чертежа, а
при выборе bak или sv$-файлов с предварительным переводом их в DWG-формат
Программа Дениса Флюстикова "Open_Den" от 13.06.07
Увеличено количество видов открываемых файлов;
Активация DWG-чертежа без повторного открытия.
Макрос для кнопки: ^C^C^P(load "Open_Den");Open_Den
Большое спасибо VVA за помощь в доработке программы
===========================================|;
(defun c:Open_Den (/ a1 a2 a3 a4)
(if (setq a2
           (if *LAST_DIR*                              ;_ <= Add VVA 18.09.2007
             (getfiled "" *LAST_DIR* "*" 16)           ;_ <= Add VVA 18.09.2007
             (getfiled "" (getvar "dwgprefix") "*" 16) ;_ <= Add VVA 18.09.2007
             ))                                        ;_ <= Add VVA 18.09.2007
  (progn
(vl-load-com)
(setq *LAST_DIR* (strcat (vl-filename-directory a2) "\\")) ;_ <= Add VVA 18.09.2007 Запоминаем папку
(VL-PROPAGATE '*LAST_DIR*)                                 ;_ <= Add VVA 18.09.2007 Тиражируем во все открытые документы
(setq a1 (strcase a2 T))
(if (vl-filename-extension a2)
(cond ((wcmatch a1 "*.exe,*.cmd,*.com,*.pif,*.lnk,*.bat,*.msi,*.dat")
(vlax-invoke-method (setq a3 (vlax-get-or-create-object "wscript.shell"))
  "run" (strcat  "\"" a2  "\"") 1 :vlax-false)
(vlax-release-object a3)
)
      ((and (wcmatch a1 "*.bak,*.sv$")
      (wcmatch (read-line (setq a3 (open a1 "r"))) "AC10*")
      )
(close a3)
(setq a1 (vl-filename-base a2))
(if (findfile (strcat (vl-filename-directory a2) "\\""" a1 ".dwg"))
(setq a1 (strcat a1 (vl-filename-extension a2))
      a3 3)
(setq a3 1))
(while a3
(if (= a3 3)
(princ (strcat "\nПапка уже содержит DWG-файл \"" (vl-filename-base a1) "\""))
(if (= a3 1)
(princ (strcat "\nВосстановление DWG-файла \"" a1 "\""))
(if (= a3 0)
(princ "\nНедопустимый символ в имени файла")
(princ (strcat "\nПапка уже содержит DWG-файл \"" a1 "\"")))))
(if (= a3 2)
(setq a3 "\nНовое имя DWG-файла:")
(setq a3 (strcat "\nНовое имя DWG-файла или <" a1 ">:")))
(setq a3 (vl-catch-all-apply 'getstring (list T a3)))
(if (= (type a3) 'STR)(progn
(setq a3 (vl-string-translate "/\\:?<*\|\"" ">>>>>>>>" (vl-string-trim " " a3)))
(if (wcmatch a3 "*>*")
(setq a3 0)
(progn
(if (= a3 "")(setq a3 a1))
(setq a1 a3
      a3 (strcat (vl-filename-directory a2) "\\""" a3 ".dwg"))
(if (findfile a3)
(setq a3 2)
(setq a1 a3
      a3 nil))
))
)
(setq a1 nil a3 nil)
)
)
(if a1 (progn
(setvar "CMDECHO" 0)
(if (vl-file-rename  a2 a1)
(command "_.vbastmt" (strcat "AcadApplication.Documents.Open\42" a1 "\42"))
(princ "\nПереименовать файл не удалось"))
(setvar "CMDECHO" 1))
))
      ((wcmatch a1 "*.dwg,*.dwt,*.dxf,*.dws")
(setvar "CMDECHO" 0)
(setq a3 0)
(vlax-for doc (vla-get-Documents (vlax-get-acad-object))
(if (= (strcase (vla-get-fullname doc) T) a1)(progn
(princ (strcat "\n" a2 " в данный момент открыт"))
(command "_.vbastmt" (strcat "AcadApplication.Documents.Item(" (itoa a3) ").Activate"))
(setq a1 nil)
))
(setq a3 (1+ a3))
)
(if a1 (command "_.vbastmt" (strcat "AcadApplication.Documents.Open\42" a1 "\42")))
(setvar "CMDECHO" 1))
      (T
(if (setq a2 (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\" (vl-filename-extension a1))))
(if (setq a3 (strcat "HKEY_CLASSES_ROOT\\" a2 "\\shell")
    a4 (vl-registry-descendents a3))
(progn (setq a4 (append '("open" "view") a4))
(while a4
(if (setq a2 (vl-registry-read (strcat a3 "\\" (car a4) "\\command")))
(setq a4 nil))
(setq a4 (cdr a4))))
(setq a2 nil)
))
(if a2 (progn
(if (= (type a2) 'LIST)(setq a2 (cdr a2)))
(setq a2 (strcase (vl-string-left-trim "\"" a2) T)
      a2 (substr a2 1 (vl-string-search "\"" a2))
      a2 (vl-string-subst "" "%systemroot%\\system32\\" a2)
      a1 (strcat "\"" a1 "\""))
(if (setq a3 (vl-string-search "%" a2))
(setq a2 (substr a2 1 a3)))
(if (setq a3 (vl-string-search ".exe " a2))
(setq a2 (substr a2 1 (+ a3 4))))
(if (not (wcmatch a2 "rundll32*"))
(setq a1 (strcat  "\"" a2  "\"" " " a1)))
(vlax-invoke-method (setq a3 (vlax-get-or-create-object "wscript.shell"))
  "run" a1 1 :vlax-false)
(vlax-release-object a3)
)
))
)
(setq a2 nil))
(if (null a2)(princ "\nПрограмма для открытия файлов данного типа не найдена"))
))
(princ)
)