Вот код 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
