Aqui está o código da nixda para 2013 que foi editado para corrigir alguns erros de digitação e remover a data da última modificação que não foi encontrada na mesma linha que o hiperlink em um arquivo html exportado do Google Chrome.
O seguinte script de clique de botão foi modificado para comentar a última parte modificada do código.
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
O módulo change_timestamp a seguir foi modificado para corrigir um erro ortográfico ao declarar a função CreateFileW em que lpFileName foi declarado como LongLong em vez de Long sob a seção # VBA7 e continuação de linha ao declarar a função CreateFileW sob a seção #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
