Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function GetCursorPos _
        Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint _
        Lib "user32.dll" ( _
        ByVal X As Long, _
        ByVal Y As Long) As Long
Private Declare Function GetClassName _
        Lib "user32.dll" Alias "GetClassNameA" ( _
        ByVal hWnd As Long, _
        ByVal lpClassName As String, _
        ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText _
        Lib "user32.dll" Alias "GetWindowTextA" ( _
        ByVal hWnd As Long, _
        ByVal lpString As String, _
        ByVal cch As Long) As Long

Private Sub GetWindowFromPoint()
    Dim iPOINT As POINTAPI, ihWnd As Long
    Dim iClass As String * 255, iCaption As String * 255

    GetCursorPos iPOINT
    ihWnd = WindowFromPoint(iPOINT.X, iPOINT.Y)
    GetClassName ihWnd, iClass, 255&
    GetWindowText ihWnd, iCaption, 255&

    MsgBox "Курсор мышки находится над окном :" & vbCrLf & _
    "Handle = " & ihWnd & vbCrLf & _
    "Class Name = " & Application.Trim(iClass) & vbCrLf & _
    "Caption Text = " & Application.Trim(iCaption), , ""
End Sub

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function GetCursorPos _
        Lib "user32.dll" (lpPoint As POINTAPI) As Long

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    If Not Intersect(Target, Me.[A1:C10]) Is Nothing Then
       Dim iPOINT As POINTAPI
       GetCursorPos iPOINT
       With Application.CommandBars("Fill Color")
            .Left = iPOINT.X
            .Top = iPOINT.Y
            .Visible = True
       End With
       Cancel = True
    End If
End Sub

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

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

Private Declare Function PathIsURL _
        Lib "shlwapi.dll" Alias "PathIsURLA" ( _
        ByVal pszPath As String) As Long

Private Sub WinAPI_IsValidHyperlink()
    Dim iAddress$
    iAddress = Range("A1").Text '"http://mail.ru"
    
    If PathIsURL(iAddress) = 1 Then
       MsgBox "Можно создавать гиперссылку", , ""
    Else
       MsgBox "Не рекомендуется", vbCritical, ""
    End If
End Sub

'Private Declare Function RegOpenKey _
'        Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
'        ByVal hKey As Long, _
'        ByVal lpSubKey As String, _
'        phkResult As Long) As Long
Private Declare Function RegOpenKeyEx _
        Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
        ByVal hKey As Long, _
        ByVal lpSubKey As String, _
        ByVal ulOptions As Long, _
        ByVal samDesired As Long, _
        phkResult As Long) As Long
Private Declare Function RegCloseKey _
        Lib "advapi32.dll" ( _
        ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx _
        Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
        ByVal hKey As Long, _
        ByVal lpValueName As String, _
        ByVal lpReserved As Long, _
        lpType As Long, _
        lpData As Any, _
        lpcbData As Long) As Long

Private Sub WinAPI_RegArchiveHyperlinks()
    Dim iKeyName$, iURL$, ihKey&, iCount&
    iCount = 1: iURL = Space(255) 'String(255, 32)
    iKeyName = "Software\Microsoft\Internet Explorer\TypedURLs"
    
    'RegOpenKey -2147483647, iKeyName, ihKey
    RegOpenKeyEx -2147483647, iKeyName, 0&, 131097, ihKey
    
    Do Until RegQueryValueEx(ihKey, "URL" & iCount, 0&, 1&, ByVal iURL, 255&) <> 0
       iURL = Trim(iURL)
       If iURL Like "mailto:*" Then '"mailto:*@*.*"
          ListBox1.AddItem iURL, 0
       Else
          ListBox1.AddItem iURL
       End If
       iCount = iCount + 1: iURL = Space(255) 'String(255, 32)
    Loop
    RegCloseKey ihKey
End Sub

Private Declare Function DoFileDownload _
        Lib "shdocvw.dll" ( _
        ByVal lpszFile As String) As Long

Private Sub WinAPI_DownloadFileWEB()
    Dim iFileName$
    iFileName = "http://www.msoffice-nm.ru/faq/files/FunctionExcel.chm"

    DoFileDownload StrConv(iFileName, vbUnicode)
End Sub