Получить абсолютную гиперссылку из относительной (WinAPI)- Visual Basic(Бейсик)

disel

Для того, чтобы перебрать все гиперссылки, расположенные в столбце «A» активного рабочего листа и получить абсолютный путь из относительного, можно воспользоваться нижеприведённым макросом. Обратите внимание на то, что лист, диапазон (столбец), а также функция MsgBox используются исключительно в качестве примера.

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Private Declare Function PathIsRelative _
        Lib "shlwapi.dll" Alias "PathIsRelativeA" ( _
        ByVal pszPath As String) As Long
Private Declare Function GetFullPathName _
        Lib "kernel32.dll" Alias "GetFullPathNameA" ( _
        ByVal lpFileName As String, _
        ByVal nBufferLength As Long, _
        ByVal lpBuffer As String, _
        ByVal lpFilePart As String) As Long
  
Private Sub getAbsoluteHyperlink()
    Dim iHyperlink As Hyperlink
    Dim iPath$, iAddress$, iAbsoluteName$
  
    iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
    If iPath = "" Then ThisWorkbook.Path
    If Not iPath Like "*\" Then iPath = iPath & "\"
  
    For Each iHyperlink In Range("A:A").Hyperlinks
        iAddress = iHyperlink.Address
        If CBool(PathIsRelative(iAddress)) = True Then
           iAbsoluteName = Space(255)
           GetFullPathName _
           iPath & iAddress, 255&, iAbsoluteName, vbNullString
           iAbsoluteName = RTrim(iAbsoluteName)
           'iAbsoluteName = Application.Clean(iAbsoluteName)
 
           MsgBox _
           "Относительная = " & iAddress & vbCr & _
           "Абсолютная = " & iAbsoluteName, , iHyperlink.Range.Address
        Else
           MsgBox "Абсолютная = " & iAddress, , iHyperlink.Range.Address
        End If
    Next
End Sub
 
 
 
Private Sub getAbsoluteHyperlink2()
    Dim iSource As Range, iHyperlink As Hyperlink
    Dim iPath$, iAddress$, iAbsoluteName$, iLength&
  
    iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
    If iPath <> "" Then
       If Right(iPath, 1) <> "\" Then iPath = iPath & "\"
    Else
       iPath = ThisWorkbook.Path & "\"
    End If
    Set iSource = ThisProject.Лист1.Columns(1)
  
    For Each iHyperlink In iSource.Hyperlinks
        iAddress = iHyperlink.Address
        If PathIsRelative(iAddress) = 1 Then
           iAbsoluteName = Space(255)
           iLength = GetFullPathName( _
           iPath & iAddress, 255&, iAbsoluteName, vbNullString)
           iAbsoluteName = Left(iAbsoluteName, iLength)
  
           MsgBox _
           "Относительная = " & iAddress & vbCr & _
           "Абсолютная = " & iAbsoluteName, , ""
        Else
           MsgBox "Абсолютная = " & iAddress, , ""
        End If
    Next
End Sub

Используемые в данном макросе функции WinAPI не проверяют ни корректность адреса гиперссылки, ни наличие файлов (папок), так что будьте внимательны.

Похожие записи/страницы:

Leave a Comment