Для того, чтобы с помощью VBA создать относительную гиперссылку file:// , т.е. гиперссылку, адрес которой будет определяться относительно базового адреса (меню Файл — команда Свойства — закладка Документ и поле База гиперссылки) или, в случае отсутствия базы гиперссылки, папки, в которой находится текущая книга (разумеется, книга с макросом, предварительно должна быть сохранена) можно использовать ниже опубликованный макрос CreateRelativeHyperlink. Обратите внимание на то, что активный лист, ячейка «A1», диалоговое окно выбора файла и т.п., используются исключительно в качестве примера.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | 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 IfEnd Sub |