Here is nixda's code for 2013 that was edited to correct a couple typos and remove last modified date that was not found on the same line as the hyperlink in an exported html file from Google Chrome.
The following button click script was modified to comment out the last modified portion of code.
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
The following change_timestamp module was modified to correct a typo when declaring CreateFileW function where lpFileName was declared as LongLong instead of Long under #VBA7 section and line continuation when declaring CreateFileW function under #Else section.
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
