Вот код nixda для 2013 года, который был отредактирован для исправления пары опечаток и удаления даты последнего изменения, которая не была найдена в той же строке, что и гиперссылка в экспортированном html-файле из Google Chrome.
Следующий скрипт нажатия кнопки был изменен, чтобы закомментировать последнюю измененную часть кода.
Private Sub CommandButton1_Click() Dim shortcutfile As String Dim myadddate As Double forbidden = Array("\", "/", ":", "*", "?", """", "<", ">", "|", """, "&", "'") Application.ScreenUpdating = False ChDir ThisWorkbook.Path myfullfilename = Application.GetOpenFilename(fileFilter:="HTML Files, *.html") If myfullfilename = False Then Exit Sub mypath = Left$(myfullfilename, InStrRev(myfullfilename, "\")) & "InternetShortCuts" & " " & Format(Now, "yyyy.mm.dd hh-mm-ss") Workbooks.OpenText FileName:=myfullfilename, Origin:=-535, DataType:=xlDelimited, Tab:=False, semicolon:=False, comma:=False, Space:=False On Error Resume Next MkDir mypath On Error GoTo 0 Set mysheet = ActiveWorkbook.Sheets(1) With mysheet For i = 1 To .UsedRange.SpecialCells(xlCellTypeLastCell).Row If InStr(UCase(.Cells(i, 1)), "<DT><H3 ADD_DATE=") <> 0 Then folderend = InStrRev(.Cells(i, 1), "<") folderstart = InStrRev(.Cells(i, 1), ">", folderend) newfolder = Mid(.Cells(i, 1), folderstart + 1, folderend - folderstart - 1) For j = 0 To UBound(forbidden) newfolder = Replace(newfolder, forbidden(j), "") Next j mypath = mypath & "\" & newfolder On Error Resume Next MkDir mypath On Error GoTo 0 End If If InStr(UCase(.Cells(i, 1)), "</DL><P>") <> 0 Then mypath = Left(mypath, InStrRev(mypath, "\") - 1) End If If InStr(UCase(.Cells(i, 1)), "HREF=") <> 0 Then urlstart = InStr(.Cells(i, 1), "HREF=") urlend = InStr(.Cells(i, 1), "ADD_DATE=") myurl = Mid(.Cells(i, 1), urlstart + 6, urlend - urlstart - 8) 'adddateend = InStr(.Cells(i, 1), "LAST_") 'myadddate = Mid(.Cells(i, 1), urlend + 10, adddateend - urlend - 12) 'myadddate = DateAdd("s", myadddate, DateSerial(1970, 1, 1)) titleend = InStrRev(.Cells(i, 1), "<") titlestart = InStrRev(.Cells(i, 1), ">", titleend) mytitle = Mid(.Cells(i, 1), titlestart + 1, titleend - titlestart - 1) mytitle = Left(mytitle, 100) For j = 0 To UBound(forbidden) mytitle = Replace(mytitle, forbidden(j), "") Next j shortcutfile = mypath & "\" & Trim(mytitle) & ".url" With CreateObject("Scripting.FileSystemObject") 'If .FileExists(shortcutfile) Then shortcutfile = mypath & "\" & Trim(mytitle) & " " & Format(myadddate, "yyyy.mm.dd hh-mm-ss") & ".url" If .FileExists(shortcutfile) Then shortcutfile = mypath & "\" & Trim(mytitle) & " " & ".url" With .CreateTextFile(shortcutfile,, True) .write "[InternetShortcut]" & vbNewLine .write "URL=" & myurl .Close End With End With Call Settimestamp(shortcutfile, myadddate) End If Next i Close .Parent.Close False End With Application.ScreenUpdating = True End Sub
Следующий модуль change_timestamp был изменен для исправления опечатки при объявлении функции CreateFileW, где lpFileName было объявлено как LongLong вместо Long в разделе # VBA7 и продолжение строки при объявлении функции CreateFileW в разделе #Else.
Option Explicit Private Const OPEN_EXISTING = &H3 Private Const FILE_SHARE_READ = &H1 Private Const FILE_SHARE_WRITE = &H2 Private Const GENERIC_WRITE = &H40000000 Public Type FileTime dwLowDateTime As Long dwHighDateTime As Long End Type Public Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type #If VBA7 Then Private Declare PtrSafe Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FileTime, lpFileTime As FileTime) As Long Private Declare PtrSafe Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FileTime) As Long Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare PtrSafe Function CreateFileW Lib "kernel32.dll" _ (ByVal lpFileName As Long, _ 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 PtrSafe Function SetFileTimeCreate Lib "kernel32" Alias "SetFileTime" _ (ByVal hFile As Long, _ CreateTime As FileTime, _ ByVal LastAccessTime As Long, _ LastModified As FileTime) As Long #Else Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FileTime, lpFileTime As FileTime) As Long Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FileTime) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function CreateFileW Lib "kernel32.dll" _ (ByVal lpFileName As Long, _ 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 SetFileTimeCreate Lib "kernel32" Alias "SetFileTime" _ (ByVal hFile As Long, _ CreateTime As FileTime, _ ByVal LastAccessTime As Long, _ LastModified As FileTime) As Long #End If '======================================================================================================================= '======================================================================================================================= '======================================================================================================================= Function Settimestamp(FileName, FileDateTime) Dim FileHandle As Long Dim Res As Long Dim ErrNum As Long Dim ErrText As String Dim tFileTime As FileTime Dim tLocalTime As FileTime Dim tSystemTime As SYSTEMTIME With tSystemTime .wYear = Year(FileDateTime) .wMonth = Month(FileDateTime) .wDay = Day(FileDateTime) .wDayOfWeek = Weekday(FileDateTime) - 1 .wHour = Hour(FileDateTime) .wMinute = Minute(FileDateTime) .wSecond = Second(FileDateTime) End With Res = SystemTimeToFileTime(lpSystemTime:=tSystemTime, lpFileTime:=tLocalTime) Res = LocalFileTimeToFileTime(lpLocalFileTime:=tLocalTime, lpFileTime:=tFileTime) FileHandle = CreateFileW(lpFileName:=StrPtr(FileName), _ dwDesiredAccess:=GENERIC_WRITE, _ dwShareMode:=FILE_SHARE_READ Or FILE_SHARE_WRITE, _ lpSecurityAttributes:=ByVal 0&, _ dwCreationDisposition:=OPEN_EXISTING, _ dwFlagsAndAttributes:=0, _ hTemplateFile:=0) Res = SetFileTimeCreate( _ hFile:=FileHandle, _ CreateTime:=tFileTime, _ LastAccessTime:=0&, _ LastModified:=tFileTime) CloseHandle FileHandle End Function
