Как программно создать относительную гиперссылку (WinAPI)?
Категория: Basic
2012-08-20 15:15:48
Для того, чтобы с помощью VBA создать относительную гиперссылку file:// , т.е. гиперссылку, адрес которой будет определяться относительно базового адреса (меню Файл - команда Свойства - закладка Документ и поле База гиперссылки) или, в случае отсутствия базы гиперссылки, папки, в которой находится текущая книга (разумеется, книга с макросом, предварительно должна быть сохранена) можно использовать нижеопубликованный макрос CreateRelativeHyperlink. Обратите внимание на то, что активный лист, ячейка "A1", диалоговое окно выбора файла и т.п., используются исключительно в качестве примера.
code: #vba
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
Поделиться: