Win10x64 Office 2016 - был удалён. Следы вычещены (cclenaer + regorganizer). Office 2010 - установлен. После этого возникла аналогичная проблема - не меняется шрифт представления для VBA редактора.
Скрытый текст
Изменение разрешения экрана н помогло, что, кажется естественным...
А если в Xx = записывать ActiveCell.Address, то отслеживаться будет адрес текущей ячейки в excel. И тогда действия юзера в другом приложении не влияет на таймер.
Скрытый текст
Код
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 CheckIfHiddenColumns()
If Cells.SpecialCells(xlCellTypeVisible).Columns.Count <> Cells.Columns.Count = True Then ' hint by BMW
MsgBox "Hidden Columns Exist"
Else
MsgBox "No Hidden Columns"
End If
End Sub
"Resolution: I copied my current Windword.BOX and Excel.BOX files from my Windows 7 device (known working without issues) to my Windows 10 and that fixed the issue. Note: My Windows 7 and Windows 10 are both running Office 2016."
Сокращённый перевод: скопировать файл Excel.box с "рабочей" станции на "проблемную"
Файл *.BOX находится здесь: C:\Users\(your computer user)\application data\Microsoft\forms\EXCEL.box
Кто-то файл *.box переименовывает и тогда создаётся новый файл. Но это на ОДИН раз. Переменовывать можно *.bat файлом, кмк...
Читал я этот источник. Имхо, шибко громоздко это всё. А у меня "громоздко" равняется "велика вероятность ошибки". Так ещё и Declare Function надо дуально сделать - для х32 и х64.
При запуске макроса, который удаляет и тут же вставляет код в ThisWorkbook/ЭтаКнига, выскакивает окно VBA. И показывается код только что внедрённый в ThisWorkbook/ЭтаКнига. Программно закрыть его можно, но это вызывает дёргание окон:
Код
SendKeys "%{F4}"
или
ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
Возможно ли подавить переключение в окно VBA?
процедура вставляющая код в ThisWorkbook/ЭтаКнига.
Скрытый текст
Код
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
Это же идентификатор языка приложения. Русской версией Офиса я открываю книгу в которой фигурирует ThisWorkbook...
Вот эта часть выдаёт ошибку:
Код
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1033: Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook")
Case 1049: Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ЭтаКнига")
Case Else: Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook")
End Select
Есть макрос вставляющий в ThisWoorkbook/ЭтаКнига код событийной процедуры. у меня это Workbook_AfterSave.
Код
Sub CreateEventProcedure()
'https://www.excel-vba.ru/chto-umeet-excel/kak-dobavit-kod-procedury-programmno-skopirovat-modul/
Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
Dim lLineNum As Long
'добавляем новую книгу
Workbooks.Add
'получаем ссылку на проект и модуль книги
Set objVBProj = ActiveWorkbook.VBProject
Set objVBComp = objVBProj.VBComponents("ЭтаКнига")
Set objCodeMod = objVBComp.CodeModule
'вставляем код
With objCodeMod
lLineNum = .CreateEventProc("Open", "Workbook")
lLineNum = lLineNum + 1
.InsertLines lLineNum, " MsgBox ""Hello World"""
End With
End Sub
Есть нюанс: "для русской версии используется ссылка на ЭтаКнига. Для английской ThisWorkbook"
Код
Set objVBComp = objVBProj.VBComponents("ThisWorkbook")
??? КАК организовать проверку для активной книги - в ней ThisWorkbook или ЭтаКнига ??? Файлы все однотипные, но одни созданы на MSO2007 EN, а другие в MSO2010 RU...
ZVI написал: Есть такая проблема, она связана не с версией Office, и не с его битностью 32/64, а именно с версией операционной системы, точнее с библиотекой FM20.DLL
If the files are truly missing they can be copied from the Windows 7 environment to the Windows 10 environment. C:\Windows\SysWow64\COMCT2.OCX (the active X controls) C:\Windows\SysWow64\FM20.dll
Я наталкнулся "на стену недопонимания" подключив надстройку в Win10+office2007. Показав собщение об отсутствии библиотеки, в коде подсвечивается функция ChrW(257)...
Эта часть была не очень важна и я эти строки с ChrW функцией закоментировал. Это заполнение было -> ComboBox5.AddItem "Pied" & ChrW(257) & "v" & ChrW(257) & "jums"
После этого выдало ту же ошибку, но уже ругнулось на другую часть кода без ChrW. Даже не запомнил на какую, поняв, что проблема не в коде.
Помогите, плиз! Как переделать этот код (перебирает ВСЕ файлы в папке), что бы можно было выбрать несколько файлов из папки (используя 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
А в этом коде обязательно отслеживать ОБЕ координаты курсора? Может достаточно следить только за одной из них? Ибо практически невозможно сдвинуть мышь, чтобы X или Y оставались константой.
При старте файла требуется указать время простоя для xTime As String через Application.InputBox. Хотелось бы обойти этот запрос и "зафиксировать" значение xTime, скажем в 3 минуты. Не смог найти как указать значение переменной.
Set xTime = "00:03:00" Set xTime = #12:03:00 AM# - оба эти варианта приводят к ошибке Object Requered.
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
Есть 2 файла с макросами: - personal.xlsb (находится в папке по умолчанию - XLSTART) - MACROS.xlsb (находится в другой папке и путь прописан в альтернативную автозагрузку при старте Excel). Есть один ньюанс - файл MACROS.XLSB сохраняется в облачную папку для доступности дома и на работе.
Так вот этот MACROS.XLSB постоянно просит сохранить при выходе из EXCEL. Даже если я с ним не проделывал никаких действий. При этом изредка позволяет сохранить по нажатию "ОК", а чаще всего не позволяет сохранить и тогда я жму "Отмена" и Excel вылетает...
Что может быть не так? Сам файл испорчен или что-то с настройками Excel'a?
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
Посоветуйте, плиз, как можно было бы изменять значение переменнойp=... каким-либо из Control'ов на UserForm? CheckBox, ControlButton, ToggleButton, CommandButton. Смысл такой, что сейчас, при инициализации формы UserForm, ListBox заполняется данными из файла %desktop% / ALL.xlsb. У меня на Рабочем столе 2 идентичных файла - ALL.xlsb и ALL2.xlsb - с разными данными.
Хотелось бы реализовать переключение файла-источника из UserForm.
Функция в таком виде (пост№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)
Сдаюсь. Не могу сообразить как этим пользоваться...
Есть макрос перебора файлов в папке. Что, куда, как? Запутался я с этими функциями.
Код
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 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