Private Sub GetCursorPosition()
 Dim PauseTime, Start, Finish, TotalTime
 Application.DisplayAlerts = True ' Разрешаем предупреждения на время работы
 'GetCursorPos iPOINT ' Запрашиваем позицию курсора и записываем в переменные
 Xx = ActiveCell.Address
 'Yy = iPOINT.Y
  
        PauseTime = 300 ' Время в секундах (60=1 мин)
Start = Timer ' Старт
        Do While Timer < Start + PauseTime ' Запускаем цикл таймера
        DoEvents ' Выход на другие процессы
        Loop
 Finish = Timer ' Время вышло.
 TotalTime = Finish - Start ' Подсчет времени простоя
 'GetCursorPos iPOINT ' Запрашиваем позицию курсора и записываем в другие переменные
 Xx2 = ActiveCell.Address
 'Yy2 = iPOINT.Y
 If Xx = Xx2 Then ' Сравниваем 1 и 2 положение курсора
 ' Начинаем действия при простое
 If ActiveWorkbook.ReadOnly Then ' Проверяем файл на "ТОЛЬКО ЧТЕНИЕ"
 Excel.ActiveSheet.Cells(1, 1).Select ' Переходим на ячейку 1,1 для устранения неоконченного ввода
 Application.DisplayAlerts = False ' Подавляем предупреждения
 'Application.Quit ' Закрываем приложение
 ActiveWorkbook.Close True
 Application.DisplayAlerts = True
 Else
 Application.DisplayAlerts = False ' Подавляем предупреждения
 Excel.ActiveWorkbook.Save ' Сохраняем активную книгу
 'Application.Quit ' Закрываем приложение
 ActiveWorkbook.Close True
 Application.DisplayAlerts = True
 
 End If
 End
 Else
 ' Тут пользователь двигал курсор
End If
Cicle ' Переходим к процедуре цыкла
End Sub

Sub CreateEventProcedure()
      Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
      Dim lLineNum As Long
      On Error Resume Next
Set objVBProj = ActiveWorkbook.VBProject
Set objVBComp = objVBProj.VBComponents(ActiveWorkbook.CodeName)
Set objCodeMod = objVBComp.CodeModule
      'вставляем код
      With objCodeMod
            lLineNum = .CreateEventProc("BeforeClose", "Workbook")
            lLineNum = lLineNum + 1
            .InsertLines lLineNum, "Application.AskToUpdateLinks = False"
      End With
End Sub

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

Dim xTime As String
Dim xWB As Workbook
 
Private Sub Workbook_Open()
'Updated by Extendoffice 2019/1/20
    On Error Resume Next
    xTime = Application.InputBox("Please specify the idle time:", "KuTool For Excel", "00:00:20", , , , , 2)
    Set xWB = ActiveWorkbook
    If xTime = "" Then Exit Sub
    Reset
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    On Error Resume Next
    If xTime = "" Then Exit Sub
    Reset
End Sub
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    If xTime = "" Then Exit Sub
    Reset
End Sub
 
Sub Reset()
    Static xCloseTime
    If xCloseTime <> 0 Then
        ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork1", , False
    End If
    xCloseTime = Now + TimeValue(xTime)
    ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork1", , True
End Sub

Private Sub UserForm_Initialize()
' positioning http://www.vbaexpress.com/kb/getarticle.php?kb_id=382#instr
    Me.StartUpPosition = 0
    Me.Top = Application.Top + Application.Height - Me.Height - 45
    Me.Left = Application.Left + Application.Width - Me.Width - 45

    Dim p As String, f As String: Application.ScreenUpdating = False
      p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\": f = "ALL.xlsb"
    If Dir(p & f) = "" Then
        MsgBox "== File is missing ==": Exit Sub
    End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Extr p, f, "all", "A1:E30000"
    With ThisWorkbook.Sheets(1)
        .Columns(2).Replace 0, Empty, xlWhole
        z = .Range("A2:E" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
        .[A:E].ClearContents
    End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
tmp
End Sub

Sub XLStoXLS() ' XLS Макрос

    On Error Resume Next: Err.Clear
     ' макрос работает только в Excel 2007 (и более новых версиях)
    If Val(Application.Version) < 12 Then Exit Sub
    ' получаем полный путь к текущему файлу Excel
   oldName$ = ActiveWorkbook.FullName
    ' выход, если файл уже в нужном формате (XLSB)
   If UCase$(oldName$) Like "*.XLSB" Then Exit Sub
    ' формируем новое имя файла (меняем расширение)
   newName$ = Left(oldName$, InStrRev(oldName$, ".")) & "xlsb"
    ' сохраняем файл под новым именем в формате XLSB
   ActiveWorkbook.SaveAs newName$, xlExcel12
    ' удаляем прежний файл (в старом формате)
If Err = 0 Then Kill oldName$
'MsgBox "1st step = Saved as XLSB."

    On Error Resume Next: Err.Clear
    ' макрос работает только в Excel 2007 (и более новых версиях)
    If Val(Application.Version) < 12 Then Exit Sub
    ' получаем полный путь к текущему файлу Excel
   oldName$ = ActiveWorkbook.FullName
    ' выход, если файл уже в нужном формате (XLSB)
   If UCase$(oldName$) Like "*.XLS" Then Exit Sub
    ' формируем новое имя файла (меняем расширение)
   newName$ = Left(oldName$, InStrRev(oldName$, ".")) & "xls"
    ' сохраняем файл под новым именем в формате XLS
   ActiveWorkbook.SaveAs newName$, xlExcel8
    ' удаляем прежний файл (в старом формате)
   If Err = 0 Then Kill oldName$
'MsgBox "Saved to XLSB and XLS"

End Sub