Hipervinculos

Buenos dias tengo el siguiente codigo:
Option Explicit
"declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub ListFiles()
Dim Msg As String
Dim Directory As String, f As String
Dim r As Long
Msg = "Seleccionar una localización que contenga los archivos que quiera poner en lista."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "" Then Directory = Directory & ""
r = 1
" Insertar encabezados
Cells.ClearContents
Cells(r, 1) = "NombreArchivo"
Cells(r, 2) = "Tamaño"
Cells(r, 3) = "Fecha/Hora"
Range("A1:C1").Font.Bold = True
" Obtener el primer achivo
f = Dir(Directory, 7)
Do While f <> ""
r = r + 1
Cells(r, 1) = f
Cells(r, 2) = FileLen(Directory & f)
Cells(r, 3) = FileDateTime(Directory & f)
" Obtener el archivo siguiente
f = Dir
Loop
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
" Fichero Matriz = Escritorio
bInfo.pidlRoot = 0&
" Título en el diálogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Seleccionar una carpeta."
Else
bInfo.lpszTitle = Msg
End If
" Escriba el directorio para volver
bInfo.ulFlags = &H1
" Mostrar el diálogo
x = SHBrowseForFolder(bInfo)
" Analice el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Lo que hace es ponerme un listado de los archivos de una carpeta en especial
Lo que deseo es modificarla para que dicho listado sea con hipervínculos a talea archivos
¿Podrías ayudarme?