Scripting.FileSystemObject и VisualLISP

Автор: | Дата: 11 Апрель 2014 · 4 коммент. 

Решил собрать в одном месте куски кода, которые касаются работы с дисками и каталогами в одном месте :) Отличительной особенностью этих кодов является обращение к Scripting.FileSystemObject.

Дисклайм: я не претендую на авторство всех лиспов. Если укажете, откуда я (как оказалось) их спер, с удовольствием укажу ссылку. Естественно, что возможности Scripting.FileSystemObject очень широки, и все их перечислять - слишком долго. Кому интересно, добро пожаловать в MSDN :)

Я же привел только те коды, которыми сам пользуюсь ;)

Получение имен всех дисков
Код честнейшим образом сперт с темы на dwg.ru (с небольшими переделками)

1
2
3
4
5
6
7
8
9
10
(defun get-drive-letters (/ lst)
  (vlax-for drive
                  (vlax-get
                    (vlax-get-or-create-object "Scripting.FileSystemObject")
                    'drives
                    ) ;_ end of vlax-get
    (setq lst (cons (vlax-get drive 'driveletter) lst))
    ) ;_ end of vlax-for
  (vl-sort lst '<)
  ) ;_ end of defun

Код показывает вообще все доступные диски, включая виртуальные (созданные, например, с помощью DaemonTools или команды Windows subst), а также сетевые диски

Получение типа привода
Имеется в виду – привод сетевой, локальный, съемный и т.п. Дублирует этот пост.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
(defun _kpblc-ws-get-drive-type (drive / svr res)
                                ;|
*    Получение типа привода.
*    Параметры вызова:
  drive  - имя привода, для которого надо получить тип
*    Возвращает:
  -1    ошибка (привод не существует или к нему нет доступа)
  1      съемный диск (дисковод или Flash-накопитель)
  2      локальный (жесткий) диск
  3      подключенный сетевой диск или указан адрес типа "\\\\server\\drive$"
  4      CD / DVD-ROM
|;
  (setq svr (vlax-get-or-create-object "Scripting.FileSystemObject"))
  (if (vl-catch-all-error-p
        (vl-catch-all-apply
          (function
            (lambda ()
              (setq res (vlax-get-property (vlax-invoke-method svr 'getdrive drive) 'drivetype))
              ) ;_ end of lambda
            ) ;_ end of function
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of vl-catch-all-error-p
    (setq res -1)
    ) ;_ end of if
  (vlax-release-object svr)
  (setq svr nil)
  res
  ) ;_ end of defun

В принципе, по комментариям должно быть все понятно :)

Гарантированный поиск каталога
В некоторых случаях обычный findfile при передаче ему в качестве аргумента имени каталога мог вернуть nil, несмотря на то, что каталог гарантированно существует. Пришлось писать замену…

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(defun vl-find-file-or-dir (path / fso res)
  (cond
    ((or (findfile path)
         (findfile (vl-string-right-trim "\" path))
         (findfile (strcat (vl-string-right-trim "\" path) "\"))
         ) ;_ end of or
     (setq res (vl-string-right-trim "\" path))
     )
    ((vl-file-directory-p path)
     (if (vl-catch-all-error-p
           (setq res (vl-catch-all-apply
                       (function
                         (lambda (/ fso)
                           (setq fso (vlax-get-or-create-object
                                       "Scripting.FileSystemObject"
                                       ) ;_ end of vlax-get-or-create-object
                                 ) ;_ end of setq
                           (vlax-invoke-method fso 'getfolder path)
                           ) ;_ end of lambda
                         ) ;_ end of function
                       ) ;_ end of vl-catch-all-apply
                 ) ;_ end of setq
           ) ;_ end of vl-catch-all-error-p
       (progn
         (setq res nil)

         ) ;_ end of progn
       (setq res (vl-string-right-trim "\" path))
       ) ;_ end of if
     (vl-catch-all-apply
       (function
         (lambda ()
           (vlax-release-object fso)
           ) ;_ end of lambda
         ) ;_ end of function
       ) ;_ end of vl-catch-all-apply
     )
    ) ;_ end of cond
  res
  ) ;_ end of defun
Удаление каталога
В завершение старой темы Некоторые особенности findfile. И несмотря на обсуждение на dwg.ru :)

Конечно, удалить каталог можно и запустив cmd-файл или скрипт. Но если надо дождаться его удаления и потом продолжить выполнение кода, мне на помощь приходит такая функция:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
(defun _kpblc-dir-delete (path / svr)
                         ;|
*    Удаляет каталог
*    Параметры вызова
  path  удаляемый каталог, строка
|;
  (if (vl-find-file-or-dir path)
    (progn
      (setq svr (vlax-get-or-create-object "Scripting.FileSystemobject"))
      (vlax-invoke-method
        svr
        'deletefolder
        (vl-string-right-trim "\" path)
        :vlax-true
        ) ;_ end of vlax-invoke-method
      (if svr
        (vlax-release-object svr)
        ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

В коде использована функция vl-find-file-or-dir.

Естественно, что каталог не будет удален, если в нем есть открытые файлы. Но я эту ситуацию в коде не предусматривал.

Является ли файл ReadOnly?
Опять же, в некоторых случаях (если честно, уже не помню, в каких) попытка проверки режима ReadOnly для файла через vl-file-systime выдавала ошибку.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
(defun _kpblc-is-file-read-only (file-name / file_hangle res)
                                ;|
*    Проверяет, является ли файл "read-only". Возвращает t, если да. Проверки
* наличия файла не выполняется.
*    Параметры вызова:
*  file-name  полное имя файла, с путем.
(_kpblc-is-file-read-only "Z:\\Устройство.dwg")
|;
  (and file-name
       (findfile file-name)
       (or (not (vl-file-systime file-name))
           ((lambda (/ svr obj res)
              (setq svr (vlax-get-or-create-object "Scripting.FileSystemObject")
                    obj (vlax-invoke-method svr 'getfile file-name)
                    res (vlax-get-property obj 'attributes)
                    ) ;_ end of setq
              (vlax-release-object obj)
              (vlax-release-object svr)
              (setq obj nil
                    svr nil
                    ) ;_ end of setq
              (/= (* 2 (/ res 2)) res)
              ) ;_ end of lambda
            )
           ) ;_ end of or
       ) ;_ end of and
  ) ;_ end of defun
Установка атрибутов файла
Можно установить (по крайней мере теоретически можно) для файла атрибуты “скрытый”, “системный” и т.п.:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
(defun _kpblc-file-attributes-set (file att / fso fso:file)
                                  ;|
*    Установка атрибутов для файла
*    Параметры вызова:
  file : полный путь к файлу
  att  : список устанавливаемых атрибутов (из вариантов "archive" "system" "hidden" "readonly")
|;
  (if (findfile file)
    (progn
      (if (vl-catch-all-error-p
            (setq err
                   (vl-catch-all-apply
                     (function
                       (lambda ()
                         (setq fso      (vlax-get-or-create-object "Scripting.FileSystemObject")
                               fso:file (vlax-invoke-method fso 'getfile file)
                               ) ;_ end of setq
                         (vlax-put-property
                           fso:file
                           'attributes
                           (apply
                             (function +)
                             (mapcar
                               '(lambda (x)
                                  (cdr (assoc x '(("archive" . 32) ("system" . 4) ("hidden" . 2) ("readonly" . 1))))
                                  ) ;_ end of lambda
                               att
                               ) ;_ end of mapcar
                             ) ;_ end of apply
                           ) ;_ end of vlax-put-property

                         ) ;_ end of lambda
                       ) ;_ end of function
                     ) ;_ end of vl-catch-all-apply
                  ) ;_ end of setq
            ) ;_ end of vl-catch-all-error-p
        (progn
          (princ (strcat "\n** error ** : " (vl-catch-all-error-message err)))
          (setq fso:att nil)
          ) ;_ end of progn
        ) ;_ end of if
      (foreach item (list fso:file fso)
        (vl-catch-all-apply (function (lambda () (vlax-release-object item))))
        ) ;_ end of foreach
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

lisp-коды:
_kpblc-dir-delete. Для работы требуется vl-find-file-or-dir.
_kpblc-is-file-read-only
_kpblc-ws-get-drive-type
get-drive-letters
vl-find-file-or-dir

Размещено в Код LISP, Новости, Функции LISP · Метки: , , ,



Комментарии

Есть 4 коммент. к “Scripting.FileSystemObject и VisualLISP”
  1. Hypocrisy пишет:
    2 Май 2014 в 20:59

    Отличная статья. Хотелось бы еще узнать можно ли используя  Scripting.FileSystemObject получить содержимое определенной папки. Если Да, то как?

  2. Кулик Алексей aka kpblc пишет:
    2 Май 2014 в 23:36

    А зачем использовать именно FileSystemObject? Есть внутри лиспа встроенная функция vl-directory-files. Мне кажется, что работать с нею будет значительно удобнее.

  3. Hypocrisy пишет:
    3 Май 2014 в 9:36

    Алексей,  эту функцию помню. Просто пришел к выводу что одного лиспа знать недостаточно, поэтому в свободное время постигаю C# и углубляюсь в возможности использования лиспа. Вот и задаю столь глупые вопросы :)

    З.Ы. Спасибо за сайт - много интересного. Так держать!

  4. Кулик Алексей aka kpblc пишет:
    3 Май 2014 в 20:23

    Для .NET я бы смотрел в сторону System.IO.Directory и его методах EnumerateDirectories, EnumerateFiles и EnumerateFileSystemEnitites. Сам с ними пока не сталкивался, поэтому говорю "почти пальцем в небо" ;)

Поделитесь своим мнением


Я не робот.