Sub GetZoloto()
    Dim elem
    On Error Resume Next
    With CreateObject("MSXML2.DOMDocument.6.0"): .async = False
         'страница выгрузки данных http://www.cbr.ru/scripts/xml_metall.asp?date_req1=12/02/2016&date_req2=12/02/2016
        url_request = ("http://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & _
            Format(InputBox("Введите начальную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy") & _
            "&date_req2=" & _
            Format(InputBox("Введите конечную дату поиска в формате ДД.ММ.ГГГГ", "Курс Золота", Date), "dd\/mm\/yyyy"))
        If Not .Load(url_request) Then Exit Sub
        Set elem = .SelectSingleNode("*/Record[@Code='1'][last()]/Buy")
        If Not elem Is Nothing Then ActiveCell.Value = CDbl(elem.Text)
        Set elem = Nothing
    End With
End Sub

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

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

Option Explicit

Private Sub CommandButton1_Click()
    Dim strFolder$, strFilePath, strNewFilePath$, hFileAttr&
    Dim FT As FILETIMES, DocProp(1 To 6) As Variant, bool As Boolean
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Application.ScreenUpdating = False
    For Each strFilePath In FilenamesCollection(strFolder, ".doc")
        With Documents.Open(strFilePath, , True)
            strNewFilePath = Left(.FullName, InStrRev(.FullName, ".")) & "docx"
            bool = ReadFromfile(strFilePath, FT, hFileAttr, .BuiltInDocumentProperties, DocProp)
            If bool Then .SaveAs2 strNewFilePath, 12
            .Close
        End With
        If bool And write2file(strNewFilePath, FT, hFileAttr, DocProp) Then
            Kill strFilePath 'удаление исходного файла
        Else
            CreateObject("wscript.shell").Run "%comspec% /k ""echo " & strFilePath & " >> """ & _
                CreateObject("shell.application").NameSpace(0).Self.Path & "\ошибки.txt"""""
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function НБРБ(Optional ByVal Curr$ = "USD", Optional ByVal dDate As Date) As Currency
    Dim ondate$
    With CreateObject("msxml.DOMDocument")
        ondate = "?ondate=" & Format(IIf(dDate, dDate, Date), "mm/dd/yyyy")
        .async = 0: .Load "http://www.nbrb.by/Services/XmlExRates.aspx" & ondate
        With .SelectSingleNode("*/Currency[CharCode='" & UCase(Curr) & "']")
            НБРБ = CCur(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text)
        End With
    End With
End Function