Пакетное конвертирование doc в docx с сохранением атрибутов - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Пакетное конвертирование doc в docx с сохранением атрибутов - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: _Boroda_, китин

Пакетное конвертирование doc в docx с сохранением атрибутов

Пакетное конвертирование doc в docx с сохранением атрибутов

Дата: Понедельник, 08.02.2016, 11:37 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Доброе время суток!

Задача: Имеется папка с белее чем 10000 подпапок и файлов разнообразных форматов. Требуется найти в этой куче файлы *.doc и конвертировать их в *.docx с сохранением атрибутов (дата/время последнего изменения файла) и последующим удалением исходных *.doc файлов. Новые *.docx файлы должны быть сохранены в тех же папках, что и их исходные *.doc файлы.

Прошу помощи в решении задачи. Пытался использовать программы конвертеры, но они не удовлетворяют всем указанным условиям задачи

Ответить

Дата: Понедельник, 08.02.2016, 11:41 | Сообщение № 2

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Начальству захотелось траву в зеленый цвет покрасить?

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Понедельник, 08.02.2016, 11:47 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

RAN, типа того.

Сообщение отредактировал Didrou - Понедельник, 08.02.2016, 13:11

Ответить

Дата: Вторник, 09.02.2016, 21:10 | Сообщение № 4

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

[vba]

Код

Private Sub CommandButton1_Click()
    Dim coll As Collection, strFolder As String, strFilePath
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1)
    End With
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        With Documents.Open(strFilePath)
            .SaveAs2 Left(.FullName, InStrRev(.FullName, ".")) & "docx", 12
            .Close
            Kill strFilePath 'удаление исходного файла
        End With
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

код функции FilenamesCollection взял тут

К сообщению приложен файл: Doc1.doc (54.5 Kb)

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Дата: Среда, 10.02.2016, 10:58 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

krosav4ig, за скрипт спасибо, работает хорошо, но он не ~~меняет~~ сохраняет атрибуты файла, а ставит новые (текущие дату и время). Попробую сам доработать, пока никто не отпишется с доработанным скриптом.

Сообщение отредактировал Didrou - Среда, 10.02.2016, 11:15

Ответить

Дата: Четверг, 11.02.2016, 11:09 | Сообщение № 6

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

Didrou, какие дату и время нужно сохранять? Дату самого файла (в свойствах файла на вкладке общая) или те, что BuiltInDocumentProperties(11) и BuiltInDocumentProperties(12) (в свойствах файла на вкладке сводка > дополнительно>>), или и то и другое? Номер редакции, имя последнего сохранившего, общее время редактирования сохранять, название приложения которым последний раз сохранялся сохранять нужно?

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Четверг, 11.02.2016, 11:20

Ответить

Дата: Четверг, 11.02.2016, 16:35 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

krosav4ig, дату последнего изменения файла. "ПКМ -> Свойства -> Общие -> Изменен" - нужна эта дата, время не обязательно. Перенести её со старого *.doc файла в конвертированный *.docx.

Ответить

Дата: Пятница, 12.02.2016, 00:08 | Сообщение № 8

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

в общем, понагородил все подряд ...

[vba]

Код

Option Explicit

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Private Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long

Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ = &H80000000, _
    OPEN_EXISTING& = 3

Private Sub CommandButton1_Click()
    Dim strFolder$
    Dim CreationTime As FILETIME, _
        LastAccessTime As FILETIME, _
        LastWriteTime As FILETIME
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Dim coll As Collection, strFilePath, strNewFilePath$, hFile&, hFileAttr&
    Dim DocProp(1 To 6) As Variant, objTimeZone As Object, zip$, TZOffset#
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        'создаем файловый дескриптор, указывающий на исходный файл
        hFile = CreateFile(strFilePath, GENERIC_READ, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        With Documents.Open(strFilePath)
            strNewFilePath = Left(.FullName, InStrRev(.FullName, ".")) & "docx"
            'этот блок нужен для переноса встроенных свойств файла
            '7-last author,8=revision number,9-application name,11-creation date
            '12-last save time,13-total editing time
            With .BuiltInDocumentProperties
                DocProp(1) = .Item(7): DocProp(2) = .Item(8)
                DocProp(3) = .Item(9): DocProp(4) = .Item(11)
                DocProp(5) = .Item(12): DocProp(6) = .Item(13)
            End With
            .SaveAs strNewFilePath, 12: .Convert: .Save
            .Close: 'Kill strFilePath 'удаление исходного файла
        End With
        'определяем часовой пояс
        With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
            For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
                TZOffset = objTimeZone.Bias / 1440
            Next
        End With
        'заменяем встроенные свойства скопированного файла
        zip = "%ProgramFiles(x86)%\7-Zip\7z.exe"
        With CreateObject("wscript.shell")
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            With CreateObject("MSXML2.DOMDocument.4.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\core.xml"
                .setProperty "SelectionLanguage", "XPath"
                .setProperty "SelectionNamespaces", _
                    "xmlns:cp='http://schemas.openxmlformats.org/package/2006/metadata/core-properties' " & _
                    "xmlns:dc='http://purl.org/dc/elements/1.1/' " & _
                    "xmlns:dcterms='http://purl.org/dc/terms/' " & _
                    "xmlns:dcmitype='http://purl.org/dc/dcmitype/' " & _
                    "xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'"
                .SelectSingleNode("//cp:lastModifiedBy").Text = DocProp(1)
                .SelectSingleNode("//cp:revision").Text = DocProp(2)
                .SelectSingleNode("//dcterms:created").Text = _
                    Format(DocProp(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .SelectSingleNode("//dcterms:modified").Text = _
                    Format(DocProp(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .Save Environ("tmp") & "\docProps\core.xml"
            End With
            With CreateObject("MSXML2.DOMDocument.3.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\app.xml"
                .SelectSingleNode("//Application").Text = DocProp(3)
                .SelectSingleNode("//TotalTime").Text = DocProp(6)
                .Save Environ("tmp") & "\docProps\app.xml"
            End With
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            Kill Environ("tmp") & "\docProps\*.*"
            RmDir Environ("tmp") & "\docProps"
        End With
        'создаем файловый дескриптор, указывающий на конвертированный файл
        hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

в общем, понагородил все подряд ...

[vba]

Код

Option Explicit

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Private Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long

Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ = &H80000000, _
    OPEN_EXISTING& = 3

Private Sub CommandButton1_Click()
    Dim strFolder$
    Dim CreationTime As FILETIME, _
        LastAccessTime As FILETIME, _
        LastWriteTime As FILETIME
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Dim coll As Collection, strFilePath, strNewFilePath$, hFile&, hFileAttr&
    Dim DocProp(1 To 6) As Variant, objTimeZone As Object, zip$, TZOffset#
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        'создаем файловый дескриптор, указывающий на исходный файл
        hFile = CreateFile(strFilePath, GENERIC_READ, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        With Documents.Open(strFilePath)
            strNewFilePath = Left(.FullName, InStrRev(.FullName, ".")) & "docx"
            'этот блок нужен для переноса встроенных свойств файла
            '7-last author,8=revision number,9-application name,11-creation date
            '12-last save time,13-total editing time
            With .BuiltInDocumentProperties
                DocProp(1) = .Item(7): DocProp(2) = .Item(8)
                DocProp(3) = .Item(9): DocProp(4) = .Item(11)
                DocProp(5) = .Item(12): DocProp(6) = .Item(13)
            End With
            .SaveAs strNewFilePath, 12: .Convert: .Save
            .Close: 'Kill strFilePath 'удаление исходного файла
        End With
        'определяем часовой пояс
        With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
            For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
                TZOffset = objTimeZone.Bias / 1440
            Next
        End With
        'заменяем встроенные свойства скопированного файла
        zip = "%ProgramFiles(x86)%\7-Zip\7z.exe"
        With CreateObject("wscript.shell")
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            With CreateObject("MSXML2.DOMDocument.4.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\core.xml"
                .setProperty "SelectionLanguage", "XPath"
                .setProperty "SelectionNamespaces", _
                    "xmlns:cp='http://schemas.openxmlformats.org/package/2006/metadata/core-properties' " & _
                    "xmlns:dc='http://purl.org/dc/elements/1.1/' " & _
                    "xmlns:dcterms='http://purl.org/dc/terms/' " & _
                    "xmlns:dcmitype='http://purl.org/dc/dcmitype/' " & _
                    "xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'"
                .SelectSingleNode("//cp:lastModifiedBy").Text = DocProp(1)
                .SelectSingleNode("//cp:revision").Text = DocProp(2)
                .SelectSingleNode("//dcterms:created").Text = _
                    Format(DocProp(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .SelectSingleNode("//dcterms:modified").Text = _
                    Format(DocProp(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .Save Environ("tmp") & "\docProps\core.xml"
            End With
            With CreateObject("MSXML2.DOMDocument.3.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\app.xml"
                .SelectSingleNode("//Application").Text = DocProp(3)
                .SelectSingleNode("//TotalTime").Text = DocProp(6)
                .Save Environ("tmp") & "\docProps\app.xml"
            End With
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            Kill Environ("tmp") & "\docProps\*.*"
            RmDir Environ("tmp") & "\docProps"
        End With
        'создаем файловый дескриптор, указывающий на конвертированный файл
        hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]krosav4ig

К сообщению приложен файл: 7410728.doc (71.0 Kb)

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Пятница, 12.02.2016, 00:08

Ответить

Сообщениев общем, понагородил все подряд ...

[vba]

Код

Option Explicit

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Private Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long

Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ = &H80000000, _
    OPEN_EXISTING& = 3

Private Sub CommandButton1_Click()
    Dim strFolder$
    Dim CreationTime As FILETIME, _
        LastAccessTime As FILETIME, _
        LastWriteTime As FILETIME
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Dim coll As Collection, strFilePath, strNewFilePath$, hFile&, hFileAttr&
    Dim DocProp(1 To 6) As Variant, objTimeZone As Object, zip$, TZOffset#
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        'создаем файловый дескриптор, указывающий на исходный файл
        hFile = CreateFile(strFilePath, GENERIC_READ, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        With Documents.Open(strFilePath)
            strNewFilePath = Left(.FullName, InStrRev(.FullName, ".")) & "docx"
            'этот блок нужен для переноса встроенных свойств файла
            '7-last author,8=revision number,9-application name,11-creation date
            '12-last save time,13-total editing time
            With .BuiltInDocumentProperties
                DocProp(1) = .Item(7): DocProp(2) = .Item(8)
                DocProp(3) = .Item(9): DocProp(4) = .Item(11)
                DocProp(5) = .Item(12): DocProp(6) = .Item(13)
            End With
            .SaveAs strNewFilePath, 12: .Convert: .Save
            .Close: 'Kill strFilePath 'удаление исходного файла
        End With
        'определяем часовой пояс
        With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
            For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
                TZOffset = objTimeZone.Bias / 1440
            Next
        End With
        'заменяем встроенные свойства скопированного файла
        zip = "%ProgramFiles(x86)%\7-Zip\7z.exe"
        With CreateObject("wscript.shell")
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            With CreateObject("MSXML2.DOMDocument.4.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\core.xml"
                .setProperty "SelectionLanguage", "XPath"
                .setProperty "SelectionNamespaces", _
                    "xmlns:cp='http://schemas.openxmlformats.org/package/2006/metadata/core-properties' " & _
                    "xmlns:dc='http://purl.org/dc/elements/1.1/' " & _
                    "xmlns:dcterms='http://purl.org/dc/terms/' " & _
                    "xmlns:dcmitype='http://purl.org/dc/dcmitype/' " & _
                    "xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'"
                .SelectSingleNode("//cp:lastModifiedBy").Text = DocProp(1)
                .SelectSingleNode("//cp:revision").Text = DocProp(2)
                .SelectSingleNode("//dcterms:created").Text = _
                    Format(DocProp(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .SelectSingleNode("//dcterms:modified").Text = _
                    Format(DocProp(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .Save Environ("tmp") & "\docProps\core.xml"
            End With
            With CreateObject("MSXML2.DOMDocument.3.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\app.xml"
                .SelectSingleNode("//Application").Text = DocProp(3)
                .SelectSingleNode("//TotalTime").Text = DocProp(6)
                .Save Environ("tmp") & "\docProps\app.xml"
            End With
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            Kill Environ("tmp") & "\docProps\*.*"
            RmDir Environ("tmp") & "\docProps"
        End With
        'создаем файловый дескриптор, указывающий на конвертированный файл
        hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
    Next
    Application.ScreenUpdating = True
End Sub

[/vba]

Автор - krosav4ig
Дата добавления - 12.02.2016 в 00:08

Дата: Пятница, 12.02.2016, 08:25 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Скрипт выдает ошибку. Скрин приложил.

К сообщению приложен файл: 5070925.gif (87.9 Kb)

Ответить

Дата: Пятница, 12.02.2016, 10:58 | Сообщение № 10

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

Совсем забыл, должен быть установлен 7zip и вот тут нужно проверить к нему путь [vba]

Код

zip = "%ProgramFiles(x86)%\7-Zip\7z.exe"

[/vba] может быть просто удалить (x86) (если битность ОС совпадает с битностью 7zip)

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Дата: Пятница, 12.02.2016, 14:57 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

krosav4ig, теперь работает. Есть один не приятный момент, когда попадается файл с тильдой (~) или долларом ($) в имени, вылетает ошибка. На скрине видно. И старые *.doc файлы не удаляются. Но это не беда, сначала можно убить простым скриптом все эти не нужные файлы из-за которых ошибка + похожим скриптом удалить *.doc после конвертирования.

Спасибо тебе!

К сообщению приложен файл: 9303852.gif (34.6 Kb)

Сообщение отредактировал Didrou - Пятница, 12.02.2016, 15:15

Ответить

Дата: Пятница, 12.02.2016, 15:03 | Сообщение № 12

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

и второй

К сообщению приложен файл: 0528584.gif (76.9 Kb)

Ответить

Дата: Пятница, 12.02.2016, 15:16 | Сообщение № 13

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 902 ±

Замечаний: 0% ±

Excel 2010, 2016

Didrou, добавьте проверку имени файла:
[vba]

Код

For Each strFilePath In coll
If InStr(strFilePath, "~$") = 0 Then
'код пересохранения файла
'...
End If
Next

[/vba]

ЯД: 410013299366744 WM: R193491431804

Ответить

Дата: Пятница, 12.02.2016, 15:24 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Хм... теперь та же ошибка в той же строчке но на обычный файл, просто файл пустой.

К сообщению приложен файл: 0391702.doc (10.5 Kb)

Ответить

Дата: Пятница, 12.02.2016, 17:41 | Сообщение № 15

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 902 ±

Замечаний: 0% ±

Excel 2010, 2016

Didrou, отсутствует дата последнего сохранения...
Пропишите перед началом цикла [vba]

Код

On Error Resume Next

[/vba]

ЯД: 410013299366744 WM: R193491431804

Ответить

Дата: Суббота, 13.02.2016, 21:20 | Сообщение № 16

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

Цитата Didrou, 12.02.2016 в 14:57, в сообщении № 11

старые *.doc файлы не удаляются

это я забыл удаление раскомментировать
путь к 7z.exe лучше прописать полностью ибо как-то странно себя ведет переменная среды ProgramFiles в vba
проверку на "временность" файла (~$) сделал в функции GetAllFileNamesUsingFSO, чтобы не гонять лишний раз по циклам

при возникновении ошибок файл не конвертируется, его путь пишется в файл ошибки.txt на рабочий стол

[vba]

Код

Public Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Private Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask And Not fil.Name Like "[~$]*" Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    '  перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

[/vba]

[vba]

Код

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type FILETIMES
    CreationTime As FILETIME
    LastAccessTime As FILETIME
    LastWriteTime As FILETIME
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Public Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ& = &H80000000, _
    OPEN_EXISTING& = 3, _
    FILE_SHARE_READ& = &H1, _
    INVALID_HANDLE_VALUE& = -1, _
    zip$ = "C:\Program Files (x86)\7-Zip\7z.exe"

Public Function ReadFromfile(strFilePath, ByRef FT As FILETIMES, ByRef hFileAttr&, p1, ByRef p2 As Variant) As Boolean
    Dim hFile&
    'читаем встроенные свойства исходного файла
    With p1
        On Error Resume Next
        p2(1) = .Item(7): p2(2) = .Item(8)
        p2(3) = .Item(9): p2(4) = .Item(11)
        p2(5) = .Item(12): p2(6) = .Item(13)
        Err.Clear
    End With
    'создаем файловый дескриптор, указывающий на исходный файл
    hFile = CreateFile(strFilePath, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, 1, 0&)
    If hFile <> INVALID_HANDLE_VALUE Then
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'читаем атрибуты файла
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        ReadFromfile = (Err.Number + GetLastError) = 0
    End If
End Function
Public Function write2file(strNewFilePath$, FT As FILETIMES, hFileAttr&, p2 As Variant) As Boolean
    Dim hFile&, objTimeZone, TZOffset#
    On Error Resume Next
    'определяем часовой пояс
    With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
        For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
            TZOffset = objTimeZone.Bias / 1440
        Next
    End With
    'заменяем встроенные свойства скопированного файла
    With CreateObject("wscript.shell")
        Err.Clear
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\core.xml -y""", 0, 1
        With CreateObject("MSXML2.DOMDocument.6.0")
            .async = False: .validateOnParse = False
            .Load Environ("tmp") & "\docProps\core.xml"
            If Not IsEmpty(p2(1)) Then _
                .SelectSingleNode("//*[local-name()='lastModifiedBy']").Text = p2(1)
            If Not IsEmpty(p2(2)) Then _
                .SelectSingleNode("//*[local-name()='revision']").Text = p2(2)
            If Not IsEmpty(p2(4)) Then _
                .SelectSingleNode("//*[local-name()='created']").Text = _
                    Format(p2(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            If Not IsEmpty(p2(5)) Then _
                .SelectSingleNode("//*[local-name()='modified']").Text = _
                    Format(p2(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            .Save Environ("tmp") & "\docProps\core.xml"
            .Load Environ("tmp") & "\docProps\app.xml"
            If Not IsEmpty(p2(3)) Then _
                .SelectSingleNode("//*[local-name()='Application']").Text = p2(3)
            If Not IsEmpty(p2(6)) Then _
                .SelectSingleNode("//*[local-name()='TotalTime']").Text = p2(6)
            .Save Environ("tmp") & "\docProps\app.xml"
        End With
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        Kill Environ("tmp") & "\docProps\*.*"
        RmDir Environ("tmp") & "\docProps"
    End With
    'создаем файловый дескриптор, указывающий на конвертированный файл
    hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
    If hFile <> INVALID_HANDLE_VALUE& Then
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'заменяем атрибуты файла
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
        write2file = (Err.Number + GetLastError) = 0
    End If
End Function

[/vba]

Цитата Didrou, 12.02.2016 в 14:57, в сообщении № 11

старые *.doc файлы не удаляются

это я забыл удаление раскомментировать
путь к 7z.exe лучше прописать полностью ибо как-то странно себя ведет переменная среды ProgramFiles в vba
проверку на "временность" файла (~$) сделал в функции GetAllFileNamesUsingFSO, чтобы не гонять лишний раз по циклам

при возникновении ошибок файл не конвертируется, его путь пишется в файл ошибки.txt на рабочий стол

[vba]

Код

Public Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Private Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask And Not fil.Name Like "[~$]*" Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    '  перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

[/vba]

[vba]

Код

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type FILETIMES
    CreationTime As FILETIME
    LastAccessTime As FILETIME
    LastWriteTime As FILETIME
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Public Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ& = &H80000000, _
    OPEN_EXISTING& = 3, _
    FILE_SHARE_READ& = &H1, _
    INVALID_HANDLE_VALUE& = -1, _
    zip$ = "C:\Program Files (x86)\7-Zip\7z.exe"

Public Function ReadFromfile(strFilePath, ByRef FT As FILETIMES, ByRef hFileAttr&, p1, ByRef p2 As Variant) As Boolean
    Dim hFile&
    'читаем встроенные свойства исходного файла
    With p1
        On Error Resume Next
        p2(1) = .Item(7): p2(2) = .Item(8)
        p2(3) = .Item(9): p2(4) = .Item(11)
        p2(5) = .Item(12): p2(6) = .Item(13)
        Err.Clear
    End With
    'создаем файловый дескриптор, указывающий на исходный файл
    hFile = CreateFile(strFilePath, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, 1, 0&)
    If hFile <> INVALID_HANDLE_VALUE Then
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'читаем атрибуты файла
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        ReadFromfile = (Err.Number + GetLastError) = 0
    End If
End Function
Public Function write2file(strNewFilePath$, FT As FILETIMES, hFileAttr&, p2 As Variant) As Boolean
    Dim hFile&, objTimeZone, TZOffset#
    On Error Resume Next
    'определяем часовой пояс
    With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
        For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
            TZOffset = objTimeZone.Bias / 1440
        Next
    End With
    'заменяем встроенные свойства скопированного файла
    With CreateObject("wscript.shell")
        Err.Clear
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\core.xml -y""", 0, 1
        With CreateObject("MSXML2.DOMDocument.6.0")
            .async = False: .validateOnParse = False
            .Load Environ("tmp") & "\docProps\core.xml"
            If Not IsEmpty(p2(1)) Then _
                .SelectSingleNode("//*[local-name()='lastModifiedBy']").Text = p2(1)
            If Not IsEmpty(p2(2)) Then _
                .SelectSingleNode("//*[local-name()='revision']").Text = p2(2)
            If Not IsEmpty(p2(4)) Then _
                .SelectSingleNode("//*[local-name()='created']").Text = _
                    Format(p2(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            If Not IsEmpty(p2(5)) Then _
                .SelectSingleNode("//*[local-name()='modified']").Text = _
                    Format(p2(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            .Save Environ("tmp") & "\docProps\core.xml"
            .Load Environ("tmp") & "\docProps\app.xml"
            If Not IsEmpty(p2(3)) Then _
                .SelectSingleNode("//*[local-name()='Application']").Text = p2(3)
            If Not IsEmpty(p2(6)) Then _
                .SelectSingleNode("//*[local-name()='TotalTime']").Text = p2(6)
            .Save Environ("tmp") & "\docProps\app.xml"
        End With
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        Kill Environ("tmp") & "\docProps\*.*"
        RmDir Environ("tmp") & "\docProps"
    End With
    'создаем файловый дескриптор, указывающий на конвертированный файл
    hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
    If hFile <> INVALID_HANDLE_VALUE& Then
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'заменяем атрибуты файла
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
        write2file = (Err.Number + GetLastError) = 0
    End If
End Function

[/vba]

К сообщению приложен файл: 7410728.docm (50.8 Kb)

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Воскресенье, 14.02.2016, 02:17

Ответить

Сообщение

Цитата Didrou, 12.02.2016 в 14:57, в сообщении № 11

старые *.doc файлы не удаляются

это я забыл удаление раскомментировать
путь к 7z.exe лучше прописать полностью ибо как-то странно себя ведет переменная среды ProgramFiles в vba
проверку на "временность" файла (~$) сделал в функции GetAllFileNamesUsingFSO, чтобы не гонять лишний раз по циклам

при возникновении ошибок файл не конвертируется, его путь пишется в файл ошибки.txt на рабочий стол

[vba]

Код

Public Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Private Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask And Not fil.Name Like "[~$]*" Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    '  перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

[/vba]

[vba]

Код

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type FILETIMES
    CreationTime As FILETIME
    LastAccessTime As FILETIME
    LastWriteTime As FILETIME
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Public Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ& = &H80000000, _
    OPEN_EXISTING& = 3, _
    FILE_SHARE_READ& = &H1, _
    INVALID_HANDLE_VALUE& = -1, _
    zip$ = "C:\Program Files (x86)\7-Zip\7z.exe"

Public Function ReadFromfile(strFilePath, ByRef FT As FILETIMES, ByRef hFileAttr&, p1, ByRef p2 As Variant) As Boolean
    Dim hFile&
    'читаем встроенные свойства исходного файла
    With p1
        On Error Resume Next
        p2(1) = .Item(7): p2(2) = .Item(8)
        p2(3) = .Item(9): p2(4) = .Item(11)
        p2(5) = .Item(12): p2(6) = .Item(13)
        Err.Clear
    End With
    'создаем файловый дескриптор, указывающий на исходный файл
    hFile = CreateFile(strFilePath, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, 1, 0&)
    If hFile <> INVALID_HANDLE_VALUE Then
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'читаем атрибуты файла
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        ReadFromfile = (Err.Number + GetLastError) = 0
    End If
End Function
Public Function write2file(strNewFilePath$, FT As FILETIMES, hFileAttr&, p2 As Variant) As Boolean
    Dim hFile&, objTimeZone, TZOffset#
    On Error Resume Next
    'определяем часовой пояс
    With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
        For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
            TZOffset = objTimeZone.Bias / 1440
        Next
    End With
    'заменяем встроенные свойства скопированного файла
    With CreateObject("wscript.shell")
        Err.Clear
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ x """ & _
             strNewFilePath & """ docProps\core.xml -y""", 0, 1
        With CreateObject("MSXML2.DOMDocument.6.0")
            .async = False: .validateOnParse = False
            .Load Environ("tmp") & "\docProps\core.xml"
            If Not IsEmpty(p2(1)) Then _
                .SelectSingleNode("//*[local-name()='lastModifiedBy']").Text = p2(1)
            If Not IsEmpty(p2(2)) Then _
                .SelectSingleNode("//*[local-name()='revision']").Text = p2(2)
            If Not IsEmpty(p2(4)) Then _
                .SelectSingleNode("//*[local-name()='created']").Text = _
                    Format(p2(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            If Not IsEmpty(p2(5)) Then _
                .SelectSingleNode("//*[local-name()='modified']").Text = _
                    Format(p2(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
            .Save Environ("tmp") & "\docProps\core.xml"
            .Load Environ("tmp") & "\docProps\app.xml"
            If Not IsEmpty(p2(3)) Then _
                .SelectSingleNode("//*[local-name()='Application']").Text = p2(3)
            If Not IsEmpty(p2(6)) Then _
                .SelectSingleNode("//*[local-name()='TotalTime']").Text = p2(6)
            .Save Environ("tmp") & "\docProps\app.xml"
        End With
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        .Run "%comspec% /c ""cd ""%tmp%""&&""" & zip & """ u """ & _
             strNewFilePath & """ docProps\app.xml -y""", 0, 1
        Kill Environ("tmp") & "\docProps\*.*"
        RmDir Environ("tmp") & "\docProps"
    End With
    'создаем файловый дескриптор, указывающий на конвертированный файл
    hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
    If hFile <> INVALID_HANDLE_VALUE& Then
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, FT.CreationTime, FT.LastAccessTime, FT.LastWriteTime
        'заменяем атрибуты файла
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
        write2file = (Err.Number + GetLastError) = 0
    End If
End Function

[/vba]

Автор - krosav4ig
Дата добавления - 13.02.2016 в 21:20

Дата: Понедельник, 15.02.2016, 00:39 | Сообщение № 17

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

небольшая ошибочка вышла
вместо [vba]

Код

CreateObject("wscript.shell").Run "%comspec% /k ""echo " & strFilePath & " >> """ & _
CreateObject("shell.application").NameSpace(0).Self.Path & "\ошибки.txt"""""

[/vba] должно быть [vba]

Код

CreateObject("wscript.shell").Run "%comspec% /c ""echo " & strFilePath & " >> """ & _
CreateObject("shell.application").NameSpace(0).Self.Path & "\ошибки.txt""""", 0

[/vba]

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Дата: Понедельник, 15.02.2016, 09:25 | Сообщение № 18

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

krosav4ig, всё работает так как в условиях задачи. Прогонял на тестовой папке. Скоро опробую на копии рабочей папки, процесс долгий, отпишу результат.

Ответить

Дата: Понедельник, 15.02.2016, 11:27 | Сообщение № 19

Группа: Пользователи

Ранг: Новичок

Сообщений: 30

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Пока выполняется скрипт возник вопрос. Что если среди *.doc файлов будут некоторые с макросами, которые по уму надо бы сохранить не в *.docx, а в *.docm. Программа игнорирует этот момент? Этого не было в условиях задачи, только сейчас задумался.

Сообщение отредактировал Didrou - Понедельник, 15.02.2016, 11:50

Ответить

Дата: Понедельник, 15.02.2016, 15:59 | Сообщение № 20

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

Цитата Didrou, 15.02.2016 в 11:27, в сообщении № 19

Программа игнорирует этот момент?

Ога

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Пакетное конвертирование doc в docx с сохранением атрибутов

Страница 1 из 2
1
2
»

© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!