Хочу применить последовательно к каждому файле *.xls в папке какой-либо макрос. Файл в результате сохраняется с тем-же именем.
Код
ActiveWorkbook.Close True
Возможно ли сделать, что бы для файла, при сохранении, НЕ МЕНЯЛИСЬ даты открытия, сохранения, изменения, создания? Вот что-бы изменить эти данные, вроде, есть решения. А как их вообще не трогать?
Что-бы сохранить порядок сортировки в папке. Файлы сортируются по дате модификации. Есть программы для пакетного изменения дат указанных в свойствах... Но они позволяют лишь присвоить всей пачке одну и ту же дату.
jack_21, я вижу только такой способ: при открытии книги запоминать данные, при закрытии формировать и запускать VBS/JS скрипт, который будет пытаться изменить даты у этого файла в течение, скажем, 10 секунд. Вроде ничего сложного, но повозиться придется.
дата последней модификации - это полезная системная информация о файле (доступна только для чтения - и это правильно! прочитали, посмотрели и узнали, когда файл сохраняли последний раз, следит за этой датой файловая система) что можете сделать Вы: 1. меняете системную дату на нужную 2. открываете, сохраняете, закрываете файл 3. возвращаете правильную дату системе (это не обязательный пункт, если Вам по -барабану какие даты реальной последней модификации ставит система) но если файл откроет, сохранит кто-то другой (не Ваш макрос) файл снова получит соотв. дату модификации
только зачем все это??? если дата модификации не может служить нужным индентификатором для сортировки (т.е. она может служить, но системная - она Вам не нужна) если Вы знаете файл (все файлы) "в лицо" чтобы отличить его от остальных и присвоить нужную дату модификации для последующей сортировки, то с тем же успехом Вы можете сразу поместить его в массив на свое место и получить упорядоченный нужным Вам способом список файлов не убиваясь с этими никому не нужными последними датами модификации
Function GEtModFileDT(strDir, strFileName)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strDir)
GEtModFileDT=objFolder.Items.Item(strFileName).ModifyDate
End Function
после сохранения
Код
Function ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strDir)
objFolder.Items.Item(strFileName).ModifyDate = DateTime
End Function
Сдаюсь. Не могу сообразить как этим пользоваться...
Есть макрос перебора файлов в папке. Что, куда, как? Запутался я с этими функциями.
Код
Sub Get_All_File_from_Folder()
Dim sFolder As String, sFiles As String
'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
Application.ScreenUpdating = False
sFiles = Dir(sFolder & "*.xls*")
Do While sFiles <> ""
'открываем книгу
Workbooks.Open sFolder & sFiles
'действия с файлом = macros
'Запишем на первый лист книги в ячейку А1 - NEW VERSION
ActiveWorkbook.Sheets(1).Range("A1").Value = "NEW VERSION"
'Закрываем книгу с сохранением изменений
ActiveWorkbook.Close True
sFiles = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub Get_All_File_from_Folder()
Dim sFolder As String, sFiles As String
Dim FileDTM As Date
'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
Application.ScreenUpdating = False
sFiles = Dir(sFolder & "*.xls*")
Do While sFiles <> ""
'Извлекаем и запоминаем дату моификации файла
FileDTM = GEtModFileDT(sFolder, sFiles)
'открываем книгу
Workbooks.Open sFolder & sFiles
'действия с файлом = macros
'Запишем на первый лист книги в ячейку А1 - NEW VERSION
ActiveWorkbook.Sheets(1).Range("A1").Value = "NEW VERSION"
'Закрываем книгу с сохранением изменений
ActiveWorkbook.Close True
'Изменяем дату модификации файла
Result = ModFileDT(sFolder, sFiles, FileDTM)
sFiles = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function GEtModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strDir)
GEtModFileDT = objFolder.Items.Item(strFileName).ModifyDate
End Function
Function ModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant, ByVal DateTime As Date)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strDir)
objFolder.Items.Item(strFileName).ModifyDate = DateTime
End Function
Функция в таком виде (пост№8) может работать или ОБЯЗАТЕЛЬНО назначать тип переменных? Поэтому ОНО выдавало мне ошибку "91" (run-time error '91' : Object variable or with block variable not set) ?
Код
Function GEtModFileDT(strDir, strFileName)
...
Function ModFileDT(strDir, strFileName, DateTime)
Код
Function GEtModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant)
...
Function ModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant, ByVal DateTime As Date)
jack_21, Похоже да. Функции были написаны в VBS , а там с типами переменных немного все по другому, пришлось адаптировать немного под VBA. Сам был удивлен, что это потребовалось, при этом несмотря на то что например путь передается текстовый нужно именно As Variant .
Помогите, плиз! Как переделать этот код (перебирает ВСЕ файлы в папке), что бы можно было выбрать несколько файлов из папки (используя Ctrl и Shift)???
Скрытый текст
Код
Sub FilesInFolderKeepDates() ' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=99336&TITLE_SEO=99336-sokhranenie-fayla-ne-izmenyat-svoystvadaty-fayla&MID=861564#message861564
' apply MACROS for all files in folder keeping Modified Date !!!! 'disable compatabilty checker before execute!!!
Dim sFolder As String, sFiles As String
Dim FileDTM As Date
'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
Application.ScreenUpdating = False
sFiles = Dir(sFolder & "*.xls*")
Do While sFiles <> ""
'Извлекаем и запоминаем дату модификации файла
FileDTM = GEtModFileDT(sFolder, sFiles)
'открываем книгу
Workbooks.Open sFolder & sFiles
'действия с файлом = macros
'..............................................................Call.............
'Закрываем книгу с сохранением изменений
ActiveWorkbook.Close True
'Изменяем дату модификации файла
Result = ModFileDT(sFolder, sFiles, FileDTM)
sFiles = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function GEtModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strDir)
GEtModFileDT = objFolder.items.Item(strFileName).ModifyDate
End Function
Function ModFileDT(ByVal strDir As Variant, ByVal strFileName As Variant, ByVal DateTime As Date)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strDir)
objFolder.items.Item(strFileName).ModifyDate = DateTime
End Function
End Function
Function GetFilenamesCollection(Optional ByVal Title As String = "Выберите файлы для обработки", _
Optional ByVal InitialPath As String = "c:\") As FileDialogSelectedItems
' функция выводит диалоговое окно выбора нескольких файлов с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает массив путей к выбранным файлам, или пустую строку в случае отказа от выбора
With Application.FileDialog(3) ' msoFileDialogFilePicker
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
Set GetFilenamesCollection = .SelectedItems
End With
End Function
Sub ПримерИспользования_GetFilenamesCollection()
Dim СписокФайлов As FileDialogSelectedItems
Set СписокФайлов = GetFilenamesCollection("Заголовок окна", ThisWorkbook.Path) ' выводим окно выбора
' ===================== другие варианты вызова функции =====================
' стартовая папка не указана, заголовок окна по умолчанию
Set СписокФайлов = GetFilenamesCollection
' обзор файлов начинается с папки "Рабочий стол"
СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set СписокФайлов = GetFilenamesCollection("Выберите файлы на рабочем столе", СтартоваяПапка)
' ==========================================================================
If СписокФайлов Is Nothing Then Exit Sub ' выход, если пользователь отказался от выбора файлов
For Each File In СписокФайлов
Debug.Print File
Next
End Sub