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
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
вариант с 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]
на листе таблица "Запрос", обновляется по ПКМ>Обновить
вариант с 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]
на листе таблица "Запрос", обновляется по ПКМ>Обновить
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
В 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
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]
или такой вариант
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
такой вариант не подойдет? Один раз запускаем 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]
такой вариант не подойдет? Один раз запускаем 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 Например, так В модуль книги пишем код [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]
Если копирование, то 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
Function ListDatesFromRanges(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) Dim AL As Object, i& Dim D() As Date addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)" .Global = True If Not .test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) On Error Resume Next For i = 0 To 1 D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next On Error GoTo 0 Do If Not AL.Contains(D(0)) Then AL.Add D(0) D(0) = D(0) + 1 Loop While D(1) >= D(0) End With Next End With If Sort_ Then AL.Sort ListDatesFromRanges = AL.Toarray Set AL = Nothing End Function
[/vba]
Привет. Немного попаразитировал на коде
[vba]
Код
Function ListDatesFromRanges(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) Dim AL As Object, i& Dim D() As Date addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)" .Global = True If Not .test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) On Error Resume Next For i = 0 To 1 D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next On Error GoTo 0 Do If Not AL.Contains(D(0)) Then AL.Add D(0) D(0) = D(0) + 1 Loop While D(1) >= D(0) End With Next End With If Sort_ Then AL.Sort ListDatesFromRanges = AL.Toarray Set AL = Nothing End Function
"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"
"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
то ли у мну моск еще не очухался то ли че-то тут не то...
[vba]
Код
Sub test() Dim AL As Object, Dic As Object, Coll As Collection, t#, r# Dim Al1 As Object Dim Arr() Randomize Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To 10 ^ 6 r = Rnd AL.Add r Next t = Timer - t Debug.Print "filling arraylist with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Set Al1 = AL.Clone t = Timer AL.Sort t = Timer - t Debug.Print "sorting 10^6 random numbers in ascending order with Arraylist took "; Format(t, "0.0000"); " seconds" t = Timer Al1.Sort Al1.Reverse t = Timer - t Debug.Print "sorting 10^6 random numbers in descending order with Arraylist took "; Format(t, "0.0000"); " seconds" Set AL = Nothing: Set Al1 = Nothing Set Dic = CreateObject("scripting.dictionary") t = Timer For i = 1 To 10 ^ 6 r = Rnd Dic.Add r, r Next t = Timer - t Debug.Print "filling dictionary with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Arr = Dic.Items t = Timer QuickSort Arr, LBound(Arr), UBound(Arr) t = Timer - t Debug.Print "sorting 10^6 random numbers in descending order with quicksort took "; Format(t, "0.0000"); " seconds" Set Dic = Nothing Set Coll = New Collection t = Timer For i = 1 To 10 ^ 6 r = Rnd Coll.Add r Next t = Timer - t Debug.Print "filling collection with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" End Sub
[/vba]
[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]
Добавил сортировку по убыванию
[vba]
Код
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Byte = 0) Dim AL As Object, i&, Match Dim d() As Date strListRanges = ";" & strListRanges & ";" addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)" 'на всяк случай сделал выборку уникальных диапазонов дат .Global = True If Not .Test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) On Error Resume Next For i = 1 To 2 d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next On Error GoTo 0 Do If Not AL.Contains(d(0)) Then AL.Add d(0) d(0) = d(0) + 1 Loop While d(1) >= d(0) End With Next End With If Sort_ Then AL.Sort If Sort_ = 2 Then AL.Reverse ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing End Function
то ли у мну моск еще не очухался то ли че-то тут не то...
[vba]
Код
Sub test() Dim AL As Object, Dic As Object, Coll As Collection, t#, r# Dim Al1 As Object Dim Arr() Randomize Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To 10 ^ 6 r = Rnd AL.Add r Next t = Timer - t Debug.Print "filling arraylist with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Set Al1 = AL.Clone t = Timer AL.Sort t = Timer - t Debug.Print "sorting 10^6 random numbers in ascending order with Arraylist took "; Format(t, "0.0000"); " seconds" t = Timer Al1.Sort Al1.Reverse t = Timer - t Debug.Print "sorting 10^6 random numbers in descending order with Arraylist took "; Format(t, "0.0000"); " seconds" Set AL = Nothing: Set Al1 = Nothing Set Dic = CreateObject("scripting.dictionary") t = Timer For i = 1 To 10 ^ 6 r = Rnd Dic.Add r, r Next t = Timer - t Debug.Print "filling dictionary with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Arr = Dic.Items t = Timer QuickSort Arr, LBound(Arr), UBound(Arr) t = Timer - t Debug.Print "sorting 10^6 random numbers in descending order with quicksort took "; Format(t, "0.0000"); " seconds" Set Dic = Nothing Set Coll = New Collection t = Timer For i = 1 To 10 ^ 6 r = Rnd Coll.Add r Next t = Timer - t Debug.Print "filling collection with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" End Sub
[/vba]
[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]
Добавил сортировку по убыванию
[vba]
Код
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Byte = 0) Dim AL As Object, i&, Match Dim d() As Date strListRanges = ";" & strListRanges & ";" addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)" 'на всяк случай сделал выборку уникальных диапазонов дат .Global = True If Not .Test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) On Error Resume Next For i = 1 To 2 d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next On Error GoTo 0 Do If Not AL.Contains(d(0)) Then AL.Add d(0) d(0) = d(0) + 1 Loop While d(1) >= d(0) End With Next End With If Sort_ Then AL.Sort If Sort_ = 2 Then AL.Reverse ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing End Function
Sub test() Dim Coll As Collection, n& Dim s As kludge, it As kludge Dim arr() n = 10 ^ 6 Randomize Set Coll = New Collection t = Timer For i = 1 To n Set s = New kludge Coll.Add s(Rnd) Next t = Timer - t Debug.Print "filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" ReDim arr(1 To Coll.Count) i = 0 t = Timer For Each it In Coll i = i + 1 arr(i) = it.Value Next t = Timer - t Debug.Print "copying "; n; " values from objects in collection to an array took "; Format(t, "0.0000"); " seconds" End Sub
[/vba]
[vba]
Код
Private Val As Variant Public Property Get Self(v) Val = v Set Self = Me End Property Public Property Get Value() Value = Val End Property
Sub test() Dim Coll As Collection, n& Dim s As kludge, it As kludge Dim arr() n = 10 ^ 6 Randomize Set Coll = New Collection t = Timer For i = 1 To n Set s = New kludge Coll.Add s(Rnd) Next t = Timer - t Debug.Print "filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" ReDim arr(1 To Coll.Count) i = 0 t = Timer For Each it In Coll i = i + 1 arr(i) = it.Value Next t = Timer - t Debug.Print "copying "; n; " values from objects in collection to an array took "; Format(t, "0.0000"); " seconds" End Sub
[/vba]
[vba]
Код
Private Val As Variant Public Property Get Self(v) Val = v Set Self = Me End Property Public Property Get Value() Value = Val End Property
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
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]
видимо, дело в 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
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
0) Включить запись макроса 1) Нажать F5, ввести адрес нужной ячейки, нажать Enter 2) Набрать с клавиатуры фамилию, нажать Ctrl+Shif+Enter 3) Нажать Ctrl+Shif+F, выбрать белый цвет шрифта, нажать Ок 4) Нажать F5, ввести адрес нужной ячейки (A1), нажать Enter 5) Остановить запись макроса 6) Отменить изменения, выполнить макрос (нажать Alt+F8, выбрать макрос нажать Enter) 7) Убедиться, что макрос отработал корректно.
0) Включить запись макроса 1) Нажать F5, ввести адрес нужной ячейки, нажать Enter 2) Набрать с клавиатуры фамилию, нажать Ctrl+Shif+Enter 3) Нажать Ctrl+Shif+F, выбрать белый цвет шрифта, нажать Ок 4) Нажать F5, ввести адрес нужной ячейки (A1), нажать Enter 5) Остановить запись макроса 6) Отменить изменения, выполнить макрос (нажать Alt+F8, выбрать макрос нажать Enter) 7) Убедиться, что макрос отработал корректно.krosav4ig