Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Записи участника (krosav4ig) - Мир MS Excel

Результаты поиска
krosav4ig Дата: Четверг, 07.12.2017, 21:46 | Сообщение № 1481 | Тема: Открыть браузер макросом
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Добрый вечер. Может так?
[vba]
Код
Sub RunChrome(ByVal url As Variant)
    Dim v As Variant
    With CreateObject("WScript.Shell")
        On Error Resume Next
        For Each v In url
            Shell """" & .RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe\") & _
                """ --new-window """ & IIf(IsEmpty(v), url, v) & """"
        Next
    End With
End Function
Sub RunFirefox(ByVal url As Variant)
    Dim v As Variant
    With CreateObject("WScript.Shell")
        On Error Resume Next
        For Each v In url
            Shell """" & .RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\firefox.exe\") & _
                """ -new-window """ & IIf(IsEmpty(v), url, v) & """"
        Next
    End With
End Function

RunChrome array("https://www.youtube.com/?gl=RU&hl=ru","http://www.excelworld.ru/forum/2")
[/vba]


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

Сообщение отредактировал krosav4ig - Четверг, 07.12.2017, 21:49
 
Ответить
СообщениеДобрый вечер. Может так?
[vba]
Код
Sub RunChrome(ByVal url As Variant)
    Dim v As Variant
    With CreateObject("WScript.Shell")
        On Error Resume Next
        For Each v In url
            Shell """" & .RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe\") & _
                """ --new-window """ & IIf(IsEmpty(v), url, v) & """"
        Next
    End With
End Function
Sub RunFirefox(ByVal url As Variant)
    Dim v As Variant
    With CreateObject("WScript.Shell")
        On Error Resume Next
        For Each v In url
            Shell """" & .RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\firefox.exe\") & _
                """ -new-window """ & IIf(IsEmpty(v), url, v) & """"
        Next
    End With
End Function

RunChrome array("https://www.youtube.com/?gl=RU&hl=ru","http://www.excelworld.ru/forum/2")
[/vba]

Автор - krosav4ig
Дата добавления - 07.12.2017 в 21:46
krosav4ig Дата: Понедельник, 11.12.2017, 16:11 | Сообщение № 1482 | Тема: Сравнить данные в двух табличках , по 2 столбцам попарно.
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
вариант с QueryTable
в ЭтаКнига код для обновления подключения
[vba]
Код
Private WithEvents QT As QueryTable
Private Sub QT_BeforeRefresh(Cancel As Boolean)
    QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties=""excel 12.0 macro;hdr=no"";Data Source=" & ThisWorkbook.FullName
    DoEvents
End Sub
Private Sub Workbook_Open()
    Set QT = [Запрос].ListObject.QueryTable
End Sub
[/vba]

на листе таблица "Запрос", обновляется по ПКМ>Обновить

для работы должны быть включены макросы
К сообщению приложен файл: 0511762.xlsm (17.8 Kb)


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

Сообщение отредактировал krosav4ig - Понедельник, 11.12.2017, 16:29
 
Ответить
Сообщениевариант с QueryTable
в ЭтаКнига код для обновления подключения
[vba]
Код
Private WithEvents QT As QueryTable
Private Sub QT_BeforeRefresh(Cancel As Boolean)
    QT.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties=""excel 12.0 macro;hdr=no"";Data Source=" & ThisWorkbook.FullName
    DoEvents
End Sub
Private Sub Workbook_Open()
    Set QT = [Запрос].ListObject.QueryTable
End Sub
[/vba]

на листе таблица "Запрос", обновляется по ПКМ>Обновить

для работы должны быть включены макросы

Автор - krosav4ig
Дата добавления - 11.12.2017 в 16:11
krosav4ig Дата: Понедельник, 11.12.2017, 20:16 | Сообщение № 1483 | Тема: Значения массива возрастают, равны, убывают или хаотично
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Всем привет :)
у меня 64 без "="


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеВсем привет :)
у меня 64 без "="

Автор - krosav4ig
Дата добавления - 11.12.2017 в 20:16
krosav4ig Дата: Среда, 13.12.2017, 17:28 | Сообщение № 1484 | Тема: Макрос автосохранения файлов Excel
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
В PERSONAL.XSLB в модуль ЭтаКнига
[vba]
Код
Private WithEvents app As Application
Private Sub app_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error GoTo er
    Dim LastSaved$, Backup$
    LastSaved = Wb.BuiltinDocumentProperties("Last Save Time")
    Backup = Wb.Path & "\" & Replace(LastSaved, ":", ".") & " " & Wb.Name
    If Wb Is Me Or Wb.IsAddin Then Exit Sub
    If Wb.FullName <> Wb.Name And Not SaveAsUI And MsgBox("Сделать бэкап?", 36) = 6 Then
        Shell Join(Array("cmd /c copy ", Wb.FullName, " ", Backup, " /y"), """")
        Do While Dir$(Backup) = ""
            DoEvents
        Loop
    ElseIf SaveAsUI Then
        MsgBox "Тут можно чего-то написать"
    End If
er:
End Sub
Private Sub Workbook_Open()
    Set app = Application
End Sub
[/vba]
и перезапустить Excel


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеВ PERSONAL.XSLB в модуль ЭтаКнига
[vba]
Код
Private WithEvents app As Application
Private Sub app_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error GoTo er
    Dim LastSaved$, Backup$
    LastSaved = Wb.BuiltinDocumentProperties("Last Save Time")
    Backup = Wb.Path & "\" & Replace(LastSaved, ":", ".") & " " & Wb.Name
    If Wb Is Me Or Wb.IsAddin Then Exit Sub
    If Wb.FullName <> Wb.Name And Not SaveAsUI And MsgBox("Сделать бэкап?", 36) = 6 Then
        Shell Join(Array("cmd /c copy ", Wb.FullName, " ", Backup, " /y"), """")
        Do While Dir$(Backup) = ""
            DoEvents
        Loop
    ElseIf SaveAsUI Then
        MsgBox "Тут можно чего-то написать"
    End If
er:
End Sub
Private Sub Workbook_Open()
    Set app = Application
End Sub
[/vba]
и перезапустить Excel

Автор - krosav4ig
Дата добавления - 13.12.2017 в 17:28
krosav4ig Дата: Среда, 13.12.2017, 20:47 | Сообщение № 1485 | Тема: Реальное время с самообновлением
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
или такой вариант

UDF
[vba]
Код
Public Function РеальноеВремя()
    Application.Volatile True
    РеальноеВремя = Now
End Function
[/vba]

В ЭтаКнига
[vba]
Код
Private Sub Workbook_Open()
    With Лист1.Cells.Find("РеальноеВремя", , xlFormulas, xlPart)
        .Formula = .Formula
    End With
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Formula = "=РеальноеВремя()" Then recalc Target.Address(, , , 1)
End Sub
Public Sub recalc(adr)
    If Range(adr).Formula = "=РеальноеВремя()" Then
        Range(adr).Calculate
        Application.OnTime Now + TimeSerial(0, 0, 1), "'" & ThisWorkbook.Name & "'!'ЭтаКнига.recalc """ & adr & """'"
    End If
End Sub
[/vba]
К сообщению приложен файл: 0281119.xlsm (20.3 Kb)


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

Сообщение отредактировал krosav4ig - Среда, 13.12.2017, 20:50
 
Ответить
Сообщениеили такой вариант

UDF
[vba]
Код
Public Function РеальноеВремя()
    Application.Volatile True
    РеальноеВремя = Now
End Function
[/vba]

В ЭтаКнига
[vba]
Код
Private Sub Workbook_Open()
    With Лист1.Cells.Find("РеальноеВремя", , xlFormulas, xlPart)
        .Formula = .Formula
    End With
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Formula = "=РеальноеВремя()" Then recalc Target.Address(, , , 1)
End Sub
Public Sub recalc(adr)
    If Range(adr).Formula = "=РеальноеВремя()" Then
        Range(adr).Calculate
        Application.OnTime Now + TimeSerial(0, 0, 1), "'" & ThisWorkbook.Name & "'!'ЭтаКнига.recalc """ & adr & """'"
    End If
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 13.12.2017 в 20:47
krosav4ig Дата: Вторник, 19.12.2017, 13:27 | Сообщение № 1486 | Тема: Подбор номен-туры по 4 параметрам определяющим взаимозамену
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Добрый день.
А что если (вдруг), к примеру, вместо socket 1150 в таблице будет socket H3? Или socket R вместо socket 2011...


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеДобрый день.
А что если (вдруг), к примеру, вместо socket 1150 в таблице будет socket H3? Или socket R вместо socket 2011...

Автор - krosav4ig
Дата добавления - 19.12.2017 в 13:27
krosav4ig Дата: Вторник, 19.12.2017, 13:34 | Сообщение № 1487 | Тема: Подбор номен-туры по 4 параметрам определяющим взаимозамену
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
это вопрос к ТС?

К ТС :)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщение
это вопрос к ТС?

К ТС :)

Автор - krosav4ig
Дата добавления - 19.12.2017 в 13:34
krosav4ig Дата: Суббота, 23.12.2017, 17:40 | Сообщение № 1488 | Тема: SQL запрос по значению в ячейке
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
такой вариант не подойдет?
Один раз запускаем AddQt() и потом при изменении в A1 автоматически обновляется
[vba]
Код
Sub AddQT()
    Dim varConn$, varSQL$, wsh As Worksheet
    varConn = "ODBC;DSN=MS Access Database;DBQ=\\HYPERV\data\SDAT.mdb;Driver={Driver do Microsoft Access (*.mdb)}"
    varSQL = "SELECT SatAlici, SatNote FROM T_Satish WHERE (T_Satish.SatAlici  = ?)"
    Set wsh = ActiveSheet
    With wsh
        .[AN2].CurrentRegion.Delete xlUp
        With .QueryTables.Add(varConn, .[AN2], varSQL).Parameters.Add("p1", 4)
            .SetParam 2, wsh.[A1]
            .RefreshOnChange = True
            .Parent.Parent.Refresh
        End With
    End With
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениетакой вариант не подойдет?
Один раз запускаем AddQt() и потом при изменении в A1 автоматически обновляется
[vba]
Код
Sub AddQT()
    Dim varConn$, varSQL$, wsh As Worksheet
    varConn = "ODBC;DSN=MS Access Database;DBQ=\\HYPERV\data\SDAT.mdb;Driver={Driver do Microsoft Access (*.mdb)}"
    varSQL = "SELECT SatAlici, SatNote FROM T_Satish WHERE (T_Satish.SatAlici  = ?)"
    Set wsh = ActiveSheet
    With wsh
        .[AN2].CurrentRegion.Delete xlUp
        With .QueryTables.Add(varConn, .[AN2], varSQL).Parameters.Add("p1", 4)
            .SetParam 2, wsh.[A1]
            .RefreshOnChange = True
            .Parent.Parent.Refresh
        End With
    End With
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 23.12.2017 в 17:40
krosav4ig Дата: Вторник, 26.12.2017, 16:11 | Сообщение № 1489 | Тема: Как сделать автоматическое копирование ячейки?
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Если копирование, то VBA
Например, так
В модуль книги пишем код
[vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Select Case True
        Case Sh Is Me.Sheets(1) And Target.Address = "$A$1"
            Me.Sheets(2).Range("B1").Formula = Target
        Case Else
            Exit Sub
    End Select
End Sub
[/vba]


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

Сообщение отредактировал krosav4ig - Вторник, 26.12.2017, 16:12
 
Ответить
СообщениеЕсли копирование, то VBA
Например, так
В модуль книги пишем код
[vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Select Case True
        Case Sh Is Me.Sheets(1) And Target.Address = "$A$1"
            Me.Sheets(2).Range("B1").Formula = Target
        Case Else
            Exit Sub
    End Select
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 26.12.2017 в 16:11
krosav4ig Дата: Вторник, 26.12.2017, 21:56 | Сообщение № 1490 | Тема: Макрос не видит файл с расширением dll
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
может стоит погуглить Regsvr32 ?


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениеможет стоит погуглить Regsvr32 ?

Автор - krosav4ig
Дата добавления - 26.12.2017 в 21:56
krosav4ig Дата: Среда, 27.12.2017, 13:48 | Сообщение № 1491 | Тема: Автоматическое получение данных из закрытой книги.
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
а обновление каждую минуту не подойдет?
К сообщению приложен файл: 4092068.xlsx (15.8 Kb)


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

Сообщение отредактировал krosav4ig - Среда, 27.12.2017, 13:48
 
Ответить
Сообщениеа обновление каждую минуту не подойдет?

Автор - krosav4ig
Дата добавления - 27.12.2017 в 13:48
krosav4ig Дата: Четверг, 28.12.2017, 18:21 | Сообщение № 1492 | Тема: Список всех дат из указанных диапазонов
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Привет.
Немного :) попаразитировал на коде


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

Сообщение отредактировал krosav4ig - Четверг, 28.12.2017, 18:51
 
Ответить
СообщениеПривет.
Немного :) попаразитировал на коде

Автор - krosav4ig
Дата добавления - 28.12.2017 в 18:21
krosav4ig Дата: Пятница, 29.12.2017, 15:32 | Сообщение № 1493 | Тема: Выбор уникальных данных (DISTINCT)
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
видимо так нужно
[vba]
Код
"SELECT  SatAlici, max(SatNote), max(SatMalID) FROM T_Satish WHERE (T_Satish.SatAlici  = ?) group by T_Satish.SatAlici"
[/vba]


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

Сообщение отредактировал krosav4ig - Пятница, 29.12.2017, 15:47
 
Ответить
Сообщениевидимо так нужно
[vba]
Код
"SELECT  SatAlici, max(SatNote), max(SatMalID) FROM T_Satish WHERE (T_Satish.SatAlici  = ?) group by T_Satish.SatAlici"
[/vba]

Автор - krosav4ig
Дата добавления - 29.12.2017 в 15:32
krosav4ig Дата: Пятница, 29.12.2017, 19:50 | Сообщение № 1494 | Тема: Выбор уникальных данных (DISTINCT)
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
"select t2.f1 as SatAlici, t2.f2 as SatNote, t2.SatMalID from (SELECT max(t1.SatAlici) as f1, max(t1.SatNote) as f2, t1.SatMalID FROM T_Satish t1 WHERE (t1.SatAlici = ?) group by t1.SatMalID) t2"


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщение"select t2.f1 as SatAlici, t2.f2 as SatNote, t2.SatMalID from (SELECT max(t1.SatAlici) as f1, max(t1.SatNote) as f2, t1.SatMalID FROM T_Satish t1 WHERE (t1.SatAlici = ?) group by t1.SatMalID) t2"

Автор - krosav4ig
Дата добавления - 29.12.2017 в 19:50
krosav4ig Дата: Понедельник, 01.01.2018, 02:23 | Сообщение № 1495 | Тема: С Новым Годом!
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
С Новым Годом! Пусть сбудутся все хотелки и забудутся все печальки! Всего самого-самого вам и вашим близким!


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

Сообщение отредактировал krosav4ig - Понедельник, 01.01.2018, 02:43
 
Ответить
СообщениеС Новым Годом! Пусть сбудутся все хотелки и забудутся все печальки! Всего самого-самого вам и вашим близким!

Автор - krosav4ig
Дата добавления - 01.01.2018 в 02:23
krosav4ig Дата: Пятница, 05.01.2018, 22:07 | Сообщение № 1496 | Тема: Список всех дат из указанных диапазонов
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
С прошедшим wine
у krosav4ig - думаю из-за регулярки немного тормозит

и я того же мнения
тестировал скорость словаря и коллекции

то ли у мну моск еще не очухался то ли че-то тут не то...

[vba]
Код
filling arraylist with 10^6 random numbers took 10,6250 seconds
sorting 10^6 random numbers in ascending order with Arraylist took 1,3906 seconds
sorting 10^6 random numbers in descending order with Arraylist took 1,4375 seconds
filling dictionary with 10^6 random numbers took 72,2813 seconds
sorting 10^6 random numbers in descending order with quicksort took 7,3203 seconds
filling collection with 10^6 random numbers took 0,2188 seconds
[/vba]

Добавил сортировку по убыванию


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

Сообщение отредактировал krosav4ig - Пятница, 05.01.2018, 22:23
 
Ответить
СообщениеС прошедшим wine
у krosav4ig - думаю из-за регулярки немного тормозит

и я того же мнения
тестировал скорость словаря и коллекции

то ли у мну моск еще не очухался то ли че-то тут не то...

[vba]
Код
filling arraylist with 10^6 random numbers took 10,6250 seconds
sorting 10^6 random numbers in ascending order with Arraylist took 1,3906 seconds
sorting 10^6 random numbers in descending order with Arraylist took 1,4375 seconds
filling dictionary with 10^6 random numbers took 72,2813 seconds
sorting 10^6 random numbers in descending order with quicksort took 7,3203 seconds
filling collection with 10^6 random numbers took 0,2188 seconds
[/vba]

Добавил сортировку по убыванию

Автор - krosav4ig
Дата добавления - 05.01.2018 в 22:07
krosav4ig Дата: Суббота, 06.01.2018, 16:32 | Сообщение № 1497 | Тема: Список всех дат из указанных диапазонов
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
ну я же говорил ...
моск еще не очухался

а еси так?


К сообщению приложен файл: Module1.bas (0.7 Kb) · kludge.cls (0.4 Kb)


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

Сообщение отредактировал krosav4ig - Суббота, 06.01.2018, 16:36
 
Ответить
Сообщениену я же говорил ...
моск еще не очухался

а еси так?



Автор - krosav4ig
Дата добавления - 06.01.2018 в 16:32
krosav4ig Дата: Среда, 17.01.2018, 16:11 | Сообщение № 1498 | Тема: Пакетное конвертирование doc в docx. апдейт для x64
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
видимо, дело в LongPtr

[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 PtrSafe 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 LongPtr _
    ) As LongPtr
Private Declare PtrSafe Function GetFileTime _
    Lib "kernel32" ( _
        ByVal hFile As LongPtr, _
        lpCreationTime As FILETIME, _
        lpLastAccessTime As FILETIME, _
        lpLastWriteTime As FILETIME _
    ) As Long
Private Declare PtrSafe Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As LongPtr, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare PtrSafe Function GetFileAttributes _
    Lib "kernel32.dll" _
    Alias "GetFileAttributesA" ( _
        ByVal lpFileName As String _
    ) As Long
Public Declare PtrSafe Function SetFileAttributes _
    Lib "kernel32.dll" _
    Alias "SetFileAttributesA" ( _
        ByVal lpFileName As String, _
        ByVal dwFileAttributes As Long _
    ) As Long
Private Declare PtrSafe Function CloseHandle _
    Lib "kernel32" ( _
        ByVal hObject As LongPtr _
    ) As Long
Private Declare PtrSafe 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:\UsefulSoft\WinRAR\Rar.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]
К сообщению приложен файл: 2284990.docm (28.1 Kb)


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

Сообщение отредактировал krosav4ig - Среда, 17.01.2018, 16:26
 
Ответить
Сообщениевидимо, дело в LongPtr

[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 PtrSafe 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 LongPtr _
    ) As LongPtr
Private Declare PtrSafe Function GetFileTime _
    Lib "kernel32" ( _
        ByVal hFile As LongPtr, _
        lpCreationTime As FILETIME, _
        lpLastAccessTime As FILETIME, _
        lpLastWriteTime As FILETIME _
    ) As Long
Private Declare PtrSafe Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As LongPtr, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare PtrSafe Function GetFileAttributes _
    Lib "kernel32.dll" _
    Alias "GetFileAttributesA" ( _
        ByVal lpFileName As String _
    ) As Long
Public Declare PtrSafe Function SetFileAttributes _
    Lib "kernel32.dll" _
    Alias "SetFileAttributesA" ( _
        ByVal lpFileName As String, _
        ByVal dwFileAttributes As Long _
    ) As Long
Private Declare PtrSafe Function CloseHandle _
    Lib "kernel32" ( _
        ByVal hObject As LongPtr _
    ) As Long
Private Declare PtrSafe 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:\UsefulSoft\WinRAR\Rar.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
Дата добавления - 17.01.2018 в 16:11
krosav4ig Дата: Пятница, 19.01.2018, 10:28 | Сообщение № 1499 | Тема: Изменение ссылки в web запросе
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Добрый день
кавычки лишние
ActiveWorkbook.Queries.Add Name:="Table " & i, Formula:="let" & Chr(13) & "" & Chr(10) & " Источник = Web.Page(Web.Contents(""https://neftegaz.ru/catalogue/company/find/"" & i & ""?newest""))," & Chr(13) & "" & Chr(10) & " Data2 = Источник{2}[Data]," & Chr(13) & "" & Chr(10) & " #""Измененный тип"" = Table.TransformColumnTypes(Data2,{{""Название"", type text}, {""Местоположение"", type text}, {""Контакты"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Измененный тип"""


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеДобрый день
кавычки лишние
ActiveWorkbook.Queries.Add Name:="Table " & i, Formula:="let" & Chr(13) & "" & Chr(10) & " Источник = Web.Page(Web.Contents(""https://neftegaz.ru/catalogue/company/find/"" & i & ""?newest""))," & Chr(13) & "" & Chr(10) & " Data2 = Источник{2}[Data]," & Chr(13) & "" & Chr(10) & " #""Измененный тип"" = Table.TransformColumnTypes(Data2,{{""Название"", type text}, {""Местоположение"", type text}, {""Контакты"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Измененный тип"""

Автор - krosav4ig
Дата добавления - 19.01.2018 в 10:28
krosav4ig Дата: Пятница, 19.01.2018, 17:18 | Сообщение № 1500 | Тема: Макрос с последовательностью действий
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
0) Включить запись макроса
1) Нажать F5, ввести адрес нужной ячейки, нажать Enter
2) Набрать с клавиатуры фамилию, нажать Ctrl+Shif+Enter
3) Нажать Ctrl+Shif+F, выбрать белый цвет шрифта, нажать Ок
4) Нажать F5, ввести адрес нужной ячейки (A1), нажать Enter
5) Остановить запись макроса
6) Отменить изменения, выполнить макрос (нажать Alt+F8, выбрать макрос нажать Enter)
7) Убедиться, что макрос отработал корректно.


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщение0) Включить запись макроса
1) Нажать F5, ввести адрес нужной ячейки, нажать Enter
2) Набрать с клавиатуры фамилию, нажать Ctrl+Shif+Enter
3) Нажать Ctrl+Shif+F, выбрать белый цвет шрифта, нажать Ок
4) Нажать F5, ввести адрес нужной ячейки (A1), нажать Enter
5) Остановить запись макроса
6) Отменить изменения, выполнить макрос (нажать Alt+F8, выбрать макрос нажать Enter)
7) Убедиться, что макрос отработал корректно.

Автор - krosav4ig
Дата добавления - 19.01.2018 в 17:18
Поиск:

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