Option Compare Database

Option Explicit

 

' Краткая библиотека методов FSO (FileSystemObject)

' Release 1.0 от 10.10.2006

' Автор: Дмитрий С. (aka Joss) banderlogi@bk.ru

' Лицензия: freeware - свободное использование. Ссылка необязательна, но желательна.

'

' по мотивам справочника В.И.Короля "Visual Basic 6.0, Visual Basic for Aplications 6.0"

'

' Объектная модель FileSystemObject представляет собой неиерархическую структуру

' объектов (классов), позволяющих получить информацию о файловой системе компьютера

' и выполнить различные операции и каталогами этой системы.

' Объектная модель включает следующие классы

' FileSystemObject - обеспечивает доступ к файловой системе компьютера

' Drives - содержит объекты Drive, каждый из которых ассоциируется ровно с одним

'          диском в файловой системе компьютера с учетом сети

' Drive - обеспечивает информацией о заданном диске компьютера

' Folders - семейство Folders содержит объекты Folder, каждый из которых

'           ассоциирован с одним подкаталогом заданного каталога

' Folder - обеспечивает доступ к информации озаданной папке, о содержащихся в неё

'          папкахи каталогах, а также о методах перемещения папки и создании

'          текстового файла.

' Files - семейство Files содержит объекты File, каждый из которых ассоциирован

'         ровно с одним файлом

' File - обеспечивает доступ к информации о заданном файле, методов перемещения

'        и открытия файла

' TextStream - обеспечивает операции чтения/записи для текстового файла, открытого

'              в режиме последовательного доступа

'

' Данная библиотека содержит почти все методы объекта FileSystemObject (кроме тех,

' что устанавливают ссылки на другие объекты).

'

' Примечание: Здесь может возникнуть небольшая путаница: сама модель называется FileSystemObject и

' верхний объект модели называется FileSystemObject.

'

' FileSystemObject (объект) - обеспечивает доступ к файловой системе компьютера. Будучи

' объектом верхнего уровня объектной модели FileSystemObject, является "точкой входа" в

' в файловую систему компьютера. Только после его создания возможен доступ к другим

' объектам модели, их методам и свойствам

'

' Для работы должна быть подключена библиотека SCRRUN.DLL

 

'---------------------------------------------------------------------------------------

' Procedure : fnBuildPath

' DateTime  : 13.06.2006 14:24

' Author    : DSonnyh

' Purpose   : Создание строки путем слияния аргументов и добавления между ними \ (если его нет)

'---------------------------------------------------------------------------------------

'

Public Function fnBuildPath(strPath As String, strName As String) As String

' strPath - строка, имеющая смысл полного или относительного каталога

' strName - строка, имеющая смысл относительного имени каталога или файла

   On Error GoTo fnBuildPath_Error

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

 

    fnBuildPath = objFSO.BuildPath(strPath, strName)

    Set objFSO = Nothing

 

   On Error GoTo 0

   Exit Function

 

fnBuildPath_Error:

 

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fnBuildPath of Module objFSO"

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : sbCopyFile

' DateTime  : 22.06.2006 16:54

' Author    : DSonnyh

' Purpose   : копирование одного или нескольких файлов из одной папки в другую

'---------------------------------------------------------------------------------------

'

Public Sub sbCopyFile(strSource As String, strDestination As String, Optional blnOverwriteFiles As Variant)

' копирование одного или нескольких файлов из одной папки в другую

' strSource - путь и имя копируемого файла

' strDestination - путь и необязательное имя файла, в который будет производится копирование

' blnOverwriteFiles - флаг, задающий, будет ли копируемый файл записываться поверх существующего

'   с тем же именем. True (по умолчанию) означает запись файла поверх существующего без предупреждения

 

Dim OverwriteFiles As Boolean

   On Error GoTo sbCopyFile_Error

 

If Not IsMissing(blnOverwriteFiles) Then

    OverwriteFiles = blnOverwriteFiles

   Else

    OverwriteFiles = True

End If

 

Dim objFSO As FileSystemObject

Set objFSO = New FileSystemObject

objFSO.CopyFile strSource, strDestination, OverwriteFiles

Set objFSO = Nothing

 

   On Error GoTo 0

   Exit Sub

 

sbCopyFile_Error:

 

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sbCopyFile of Module objFSO"

 

End Sub

 

'---------------------------------------------------------------------------------------

' Procedure : sbCopyFolder

' DateTime  : 13.06.2006 14:13

' Author    : DSonnyh

' Purpose   : Копирование содержимого папки со всем содержимым в заданное место

'---------------------------------------------------------------------------------------

'

Public Sub sbCopyFolder(strSource As String, strDestination As String, Optional blnOverwriteFiles As Variant)

' strSource - путь и имя копируемой папки

' strDestination - путь, указывающий, куда будет копироваться папка

' blnOverwriteFiles - флаг, задающий, будет ли копируемый файл записываться поверх существующего

'   с тем же именем. True (по умолчанию) означает запись файла поверх существующего без предупреждения

' При установке флага blnOverwriteFiles в False, если папка strSource или что-то и её содержания существует

' в strDestination, генерируется ошибка времени исполнения 58: File already exists

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

' Если любой из файлов, существующий одновременно и в strSource и в strDestination имеет в последнем атрибут

' "Read only" (Только для чтения), в независимости от установки флага blnOverwriteFiles генерируется ошибка

' времени исполнения 70: Permission Denied

'

   On Error GoTo sbCopyFolder_Error

    Dim OverwriteFiles As Boolean

   

    If IsMissing(blnOverwriteFiles) Then

        OverwriteFiles = blnOverwriteFiles

       Else

        OverwriteFiles = True

    End If

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.CopyFolder strSource, strDestination, OverwriteFiles

    Set objFSO = Nothing

 

   On Error GoTo 0

   Exit Sub

 

sbCopyFolder_Error:

 

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sbCopyFolder of Module objFSO"

End Sub

 

'---------------------------------------------------------------------------------------

' Procedure : sbCreateFolder

' DateTime  : 13.06.2006 14:44

' Author    : DSonnyh

' Purpose   : создание новой папки с заданным именем

'---------------------------------------------------------------------------------------

'

Public Sub sbCreateFolder(strPath As String)

' strPath - имя создаваемой папки, может быть относительным именем. Если strPath содержит

' только имя папки, она создается в текущей папке на текущем диске

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

' Если strPath определяет уже существующую папку, генерируется ошибка 58: File already exists

 

   On Error GoTo sbCreateFolder_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.CreateFolder strPath

    Set objFSO = Nothing

 

   On Error GoTo 0

   Exit Sub

 

sbCreateFolder_Error:

 

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sbCreateFolder of Module objFSO"

End Sub

 

'---------------------------------------------------------------------------------------

' Procedure : sbDeleteFile

' DateTime  : 22.05.2006 16:45

' Author    : DSonnyh

' Purpose   : удаление одного или нескольких файлов

'---------------------------------------------------------------------------------------

'

Public Sub sbDeleteFile(strFileSpec As String, blnForce As Variant)

' удаление файлов происходит окончательно и бесповоротно - они не попадают в корзину.

' objFSO - ссылка на созданный объект FileSystemObject

' strFileSpec - путь и имя удаляемого файла (файлов). Может быть как абсолютным, так и

'            относительным. Если он опущен, то считается, что удаляемые файлы находятся в

'            текущем каталоге. Может содержать символы (* и !), но только в имени и расширении файла

'            Если файл не существует (или не существует ни одного файла, соответствующего заданному шаблону),

'            генерируется ошибка 53: File not found

' blnForce - (boolean) флаг, задающий, будут ли удаляться файлы с атрибутом Read only (Только для чтения)

'            False (по умолчанию) не позволяет удалять такие файлы

' Если удаляемый файл имеет атрибут "Только для чтения" (Read only) и флаг Force не выставлен в True,

' генерируется ошибка 70: Permission Denied

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo sbDeleteFile_Error

    Dim Force As Boolean

   

    If IsMissing(blnForce) Then

        Force = blnForce

       Else

        Force = False

    End If

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.DeleteFile strFileSpec, Force

    Set objFSO = Nothing

   

 

   On Error GoTo 0

Exit_sbDeleteFile:

   Exit Sub

 

sbDeleteFile_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре sbDeleteFile в Module objFSO"

    Resume Exit_sbDeleteFile

 

End Sub

 

'---------------------------------------------------------------------------------------

' Procedure : sbDeleteFolder

' DateTime  : 02.10.2006 15:08

' Author    : DSonnyh

' Purpose   : удаление одной или нескольких папок вместе со всем содержимым.

'---------------------------------------------------------------------------------------

'

Public Sub sbDeleteFolder(strFolderSpec As String, blnForce As Variant)

' удаление папок происходит окончательно и бесповоротно - они не попадают в корзину.

' objFSO - ссылка на созданный объект FileSystemObject

' strFolderSpec - путь и имя удаляеой папки (папок). Может быть как абсолютным, так и

'            относительным. Если он опущен, то считается, что удаляемые папки находятся в текущем

'            каталоге текущего диска. Может содержать символы (* и !), но только в последней части

'            Если папка не существует (или не существует ни одной папки, соответствующей заданному шаблону),

'            генерируется ошибка 76: Path not found

' blnForce - (boolean) флаг, задающий, будут ли удаляться файлы с атрибутом Read only (Только для чтения)

'            False (по умолчанию) не позволяет удалять такие файлы

' Если удаляемая папка или что-то из её содержимого имеет атрибут "Только для чтения" (Read only) и флаг

' Force не выставлен в True, генерируется ошибка 70: Permission Denied

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo sbDeleteFolder_Error

 

    Dim Force As Boolean

   

    If IsMissing(blnForce) Then

        Force = blnForce

       Else

        Force = False

    End If

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.DeleteFolder strFolderSpec, Force

    Set objFSO = Nothing

   

 

   On Error GoTo 0

Exit_sbDeleteFolder:

   Exit Sub

 

sbDeleteFolder_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре sbDeleteFolder в Module objFSO"

    Resume Exit_sbDeleteFolder

 

End Sub

 

'---------------------------------------------------------------------------------------

' Procedure : fnDriveExists

' DateTime  : 02.10.2006 16:20

' Author    : DSonnyh

' Purpose   : Проверка существования диска с указанным именем на локальной машине

'---------------------------------------------------------------------------------------

'

Public Function fnDriveExists(strDriveSpec As String) As Boolean

' Возвращает True - если диск существует

' objFSO - ссылка на созданный объект FileSystemObject

' strDrive - Имя проверяемого диска. Для буквенного обозначения диска strDriveSpec двоеточие

' после буквы не обязательно

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnDriveExists_Error

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnDriveExists = objFSO.DriveExists(strDriveSpec)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnDriveExists:

   Exit Function

 

fnDriveExists_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnDriveExists в Module objFSOx"

    Resume Exit_fnDriveExists

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnFileExists

' DateTime  : 17.08.2006 13:06

' Author    : DSonnyh

' Purpose   : проверка существования файла на локальной машине или в сети

'---------------------------------------------------------------------------------------

'

Public Function fnFileExists(strFileName As String) As Boolean

' objFSO - ссылка на созданный объект FileSystemObject

' strFileSpec - путь и имя проверяемого файла. Может быть как абсолютным, так и относительным.

'           Не может содержать символы шаблонов. Если путь опущен, файл ищется в текущем каталоге

'           текущего диска.

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnFileExists_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnFileExists = objFSO.FileExists(strFileName)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnFileExists:

   Exit Function

 

fnFileExists_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnFileExists в Module objFSO"

    Resume Exit_fnFileExists

 

End Function

'---------------------------------------------------------------------------------------

' Procedure : fnFolderExists

' DateTime  : 17.08.2006 13:06

' Author    : DSonnyh

' Purpose   : Проверка существования папки с заданным именем на локальной машине или в сети

'---------------------------------------------------------------------------------------

'

Public Function fnFolderExists(strFolderName As String) As Boolean

' objFSO - ссылка на созданный объект FileSystemObject

' strFolderSpec - путь и имя проверяемого файла. Может быть как абсолютным, так и относительным.

'           Не может содержать символы шаблонов. Если путь опущен, файл ищется в текущем каталоге

'           текущего диска.

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnFolderExists_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnFolderExists = objFSO.FolderExists(strFolderName)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnFolderExists:

   Exit Function

 

fnFolderExists_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnFolderExists в Module objFSO"

    Resume Exit_fnFolderExists

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetAbsolutePathName

' DateTime  : 02.10.2006 16:08

' Author    : DSonnyh

' Purpose   : Получение полного имени файла или папки по его относительному имени

'---------------------------------------------------------------------------------------

'

Public Function fnGetAbsolutePathName(strPath As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл полного или относительного имени файла или папки

' Символы шаблона могут включаться в любую часть Path

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnGetAbsolutePathName_Error

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnGetAbsolutePathName = objFSO.GetAbsolutePathName(strPath)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnGetAbsolutePathName:

   Exit Function

 

fnGetAbsolutePathName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetAbsolutePathName в Module objFSO"

    Resume Exit_fnGetAbsolutePathName

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetBaseName

' DateTime  : 24.05.2006 12:36

' Author    : DSonnyh

' Purpose   : Получение последнего компонента - имени папки или файла (без расширения)

'           : по его полному или относительному имени

'---------------------------------------------------------------------------------------

'

Public Function fnGetBaseName(strPath As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл полного или относительного имени файла или папки

' Символы шаблона могут включаться в любую часть Path

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnGetBaseName_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnGetBaseName = objFSO.GetBaseName(strPath)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnGetBaseName:

   Exit Function

 

fnGetBaseName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetBaseName в Module objFSOx"

    Resume Exit_fnGetBaseName

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetDriveName

' DateTime  : 02.10.2006 16:43

' Author    : DSonnyh

' Purpose   : Получение имени диска из имени папки или файла

'---------------------------------------------------------------------------------------

'

Public Function fnGetDriveName(strPath As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл пути (имени файла или папки)

' Если по заданному имени нельзя определить имя диска, метод возвращает пустую строку

' По относительному пути определить имя диска нельзя

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnGetDriveName_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnGetDriveName = objFSO.GetDriveName(strPath)

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnGetDriveName:

   Exit Function

 

fnGetDriveName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetDriveName в Module objFSO"

    Resume Exit_fnGetDriveName

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetExtensionName

' DateTime  : 06.10.2006 14:20

' Author    : DSonnyh

' Purpose   : Получение расширения из заданного имени файла

'---------------------------------------------------------------------------------------

'

Public Function fnGetExtensionName(strPath As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл полного или относительного пути имени файла

' Если расширение не обнаружено, возвращается пустая строка

' Передача в качестве аргумента Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo fnGetExtensionName_Error

   

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnGetExtensionName = objFSO.GetExtensionName(strPath)

    Set objFSO = Nothing

 

 

   On Error GoTo 0

Exit_fnGetExtensionName:

   Exit Function

 

fnGetExtensionName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetExtensionName в Module objFSO"

    Resume Exit_fnGetExtensionName

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetFileName

' DateTime  : 06.10.2006 14:25

' Author    : DSonnyh

' Purpose   : Получение имени (с расширением) из полного имени (пути) файла

'---------------------------------------------------------------------------------------

'

Public Function fnGetFileName(strPath As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл полного или относительного пути имени файла

' Если по заданному имени невозможно определить имя файла, возвращается пустая строка

' Передача в качестве аргумента Null генерирует ошибку 94: Invalid Use of Null

  

   On Error GoTo fnGetFileName_Error

 

Dim objFSO As FileSystemObject

Set objFSO = New FileSystemObject

fnGetFileName = objFSO.GetFileName(strPath)

Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnGetFileName:

   Exit Function

 

fnGetFileName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetFileName в Module objFSO"

    Resume Exit_fnGetFileName

 

 

End Function

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetParentFolderName

' DateTime  : 24.05.2006 12:21

' Author    : DSonnyh

' Purpose   : получение имени папки, являющейся предпоследним компонентом полного имени

'---------------------------------------------------------------------------------------

'

Public Function fnGetParentFolderName(strFileName As String) As String

' objFSO - ссылка на созданный объект FileSystemObject

' strPath - строка, имеющая смысл полного или относительного пути имени файла

' получение имени папки, являющейся предпоследним компонентом

' полного имени (пути) файла или папки

' Если по заданному имени невозможно определить имя папки, возвращается пустая строка

' Передача в качестве аргумента Null генерирует ошибку 94: Invalid Use of Null

 

Dim objFSO As FileSystemObject

   On Error GoTo fnGetParentFolderName_Error

 

Set objFSO = New FileSystemObject

fnGetParentFolderName = objFSO.GetParentFolderName(strFileName)

Set objFSO = Nothing

 

   On Error GoTo 0

   Exit Function

 

fnGetParentFolderName_Error:

 

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fnGetParentFolderName of Module objFSO"

 

End Function

 

 

'---------------------------------------------------------------------------------------

' Procedure : fnGetTempName

' DateTime  : 10.10.2006 16:57

' Author    : DSonnyh

' Purpose   : Получение имени для временного файла

'---------------------------------------------------------------------------------------

'

Public Function fnGetTempName() As String

' метод не создает файл, он только придумывает имя.

' для временной папки можно использовать myTmpFolderName = objFSO.GetBaseName(objFSO.GetTempName)

   

   On Error GoTo fnGetTempName_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    fnGetTempName = objFSO.GetTempName

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_fnGetTempName:

   Exit Function

 

fnGetTempName_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре fnGetTempName в Module objFSO"

    Resume Exit_fnGetTempName

 

 

End Function

 

 

'---------------------------------------------------------------------------------------

' Procedure : sbMoveFile

' DateTime  : 10.10.2006 17:05

' Author    : DSonnyh

' Purpose   : Перемещение одного или нескольких файлов из одной папки в другую

'---------------------------------------------------------------------------------------

'

Public Sub sbMoveFile(strSource As String, strDestination As String)

' objFSO - ссылка на созданный объект FileSystemObject

' strSource - путь и имя перемещаемого файла

' strDestination - путь, определяющий, куда будет производится перемещение

' strDestination не может содержать символы шаблонов

' strSource может содержать символы шаблонов, но только в имени файла

' если файл strSource не существует, генерируется ошибка времени исполнения 53: File not found

' Если strDestination уже существует, генерируется ошибка времени исполнения 58: File already exists

' Если strDestination не содержит разделитель \ в качестве последнего символа, в strSource нет символов шаблона,

' генерируется ошибка времени исполнения 70: Permission Denied

' Если файл strDestination имеет атрибут "Только для чтения" (Real only), генерируется ошибка времени

' исполнения 70: Permission Denied

' Передача в качестве аргумента Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo sbMoveFile_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.MoveFile strSource, strDestination

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_sbMoveFile:

   Exit Sub

 

sbMoveFile_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре sbMoveFile в Module objFSO"

    Resume Exit_sbMoveFile

 

End Sub

 

 

'---------------------------------------------------------------------------------------

' Procedure : sbMoveFolder

' DateTime  : 10.10.2006 17:25

' Author    : DSonnyh

' Purpose   : Перемещение папки со всеми содержащимися в ней папками в заданное место

'---------------------------------------------------------------------------------------

'

Public Sub sbMoveFolder(strSource As String, strDestination As String)

' objFSO - ссылка на созданный объект FileSystemObject

' strSource - путь и имя перемещаемой папки

' strDestination - путь, определяющий, куда будет производится перемещение

' strDestination не может содержать символы шаблонов

' strSource может содержать символы шаблонов, но только в имени файла

' если strSource не существует, генерируется ошибка времени исполнения 76: Path not found

' Если любой из файлов, существующий одновременно и в strSource и в strDestination имеет в последнем атрибут

' "Read only" (Только для чтения),генерируется ошибка времени исполнения 70: Permission Denied

' Передача в качестве любого из аргументов Null генерирует ошибку 94: Invalid Use of Null

 

   On Error GoTo sbMoveFolder_Error

 

    Dim objFSO As FileSystemObject

    Set objFSO = New FileSystemObject

    objFSO.MoveFolder strSource, strDestination

    Set objFSO = Nothing

 

   On Error GoTo 0

Exit_sbMoveFolder:

   Exit Sub

 

sbMoveFolder_Error:

 

    MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре sbMoveFolder в Module objFSO"

    Resume Exit_sbMoveFolder

 

End Sub