Для того, чтобы с помощью VBA создать относительную гиперссылку file:// , т.е. гиперссылку, адрес которой будет определяться относительно базового адреса (меню Файл — команда Свойства — закладка Документ и поле База гиперссылки) или, в случае отсутствия базы гиперссылки, папки, в которой находится текущая книга (разумеется, книга с макросом, предварительно должна быть сохранена) можно использовать ниже опубликованный макрос CreateRelativeHyperlink. Обратите внимание на то, что активный лист, ячейка «A1», диалоговое окно выбора файла и т.п., используются исключительно в качестве примера.
Private Declare Function PathRelativePathTo _
Lib "shlwapi.dll" Alias "PathRelativePathToA" ( _
ByVal pszPath As String, _
ByVal pszFrom As String, _
ByVal dwAttrFrom As Long, _
ByVal pszTo As String, _
ByVal dwAttrTo As Long) As Long
Private Sub CreateRelativeHyperlink()
Dim iPath$, iAddress$, iFileName 'As Variant
iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
If iPath = "" Then
iPath = ThisWorkbook.Path
Else
If iPath Like "*\" Then _
iPath = Left(iPath, Len(iPath) - 1)
End If
ChDrive Left(iPath, 3): ChDir iPath 'необязательно
iFileName = Application.GetOpenFilename( _
Title:="Выберите файл для создания гиперссылки")
If iFileName <> False Then
iAddress = Space(255)
If CBool(PathRelativePathTo( _
iAddress, iPath, 16&, CStr(iFileName), 0&)) = True Then
iAddress = RTrim(iAddress) 'Application.Clean(iAddress)
Else
iAddress = CStr(iFileName)
End If
Range("A1").Clear 'Range("A1").Hyperlinks.Delete
ActiveSheet.Hyperlinks.Add Range("A1"), iAddress
Else
MsgBox "Необходимо было выбрать файл", vbCritical, ""
End If
End Sub