Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Prüfung, ob Datei- und/oder Web-Hyperlink-Adressen existieren

Gruppe

Hyperlink

Problem

In einem neuen Tabellenblatt sollen die Hyperlinks mit der Angabe, ob die Datei bzw. die Webseite existiert, gelistet werden.

Lösung
Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.

StandardModule: basLocal

Sub CheckHyperlinks()
   Dim hyps As Hyperlinks
   Dim hyp As Hyperlink
   Dim iRow As Integer
   Dim sAddress As String, sDNS As String
   Dim bln As Boolean
   Set hyps = ActiveSheet.Hyperlinks
   Worksheets.Add
   For Each hyp In hyps
      bln = False
      iRow = iRow + 1
      Cells(iRow, 1) = hyp.Address
      sDNS = hyp.Address
      If Left(hyp.Address, 4) = "http" Then
         sDNS = Right(sDNS, Len(sDNS) - 7)
         If Right(sDNS, 1) = "/" Then
            sDNS = Left(sDNS, Len(sDNS) - 1)
         End If
         sAddress = WWWAddress(sDNS)
         If sAddress <> "" Then bln = True
      Else
         If Dir(hyp.Address) <> "" Then bln = True
      End If
      Cells(iRow, 2) = bln
   Next hyp
   Columns.AutoFit
End Sub

StandardModule: basWeb

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () _
   As Long

Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
   wVersionRequired&, lpWSAData As WinSocketDataType) _
   As Long

Private Declare Function WSACleanup Lib "WSOCK32.DLL" () _
   As Long

Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal _
   HostName$, ByVal HostLen%) As Long

Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
   (ByVal HostName$) As Long

Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" _
   (ByVal addr$, ByVal laenge%, ByVal typ%) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As _
   Any, ByVal hpvSource&, ByVal cbCopy&)

Const WS_VERSION_REQD = &H101

Const SOCKET_ERROR = -1
Const WSADescription_Len = 256
Const WSASYS_Status_Len = 128

Private Type HostDeType
   hName As Long
   hAliases As Long
   hAddrType As Integer
   hLength As Integer
   hAddrList As Long
End Type

Private Type WinSocketDataType
   wversion As Integer
   wHighVersion As Integer
   szDescription(0 To WSADescription_Len) As Byte
   szSystemStatus(0 To WSASYS_Status_Len) As Byte
   iMaxSockets As Integer
   iMaxUdpDg As Integer
   lpszVendorInfo As Long
End Type

Private Declare Function RasEnumConnections Lib "RasApi32.DLL" _
   Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As _
   Long, lpcConnections As Long) As Long

Private Declare Function RasGetConnectStatus Lib "RasApi32.DLL" _
   Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, _
   lpStatus As Any) As Long

Private Declare Function RasEnumEntries Lib "RasApi32.DLL" _
   Alias "RasEnumEntriesA" (ByVal reserved$, ByVal _
   lpszPhonebook$, lprasentryname As Any, lpcb As Long, _
   lpcEntries As Long) As Long

Private Declare Function RasHangUp Lib "RasApi32.DLL" _
   Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Const RAS_MaxEntryName = 256
Const RAS_MaxDeviceType = 16
Const RAS_MaxDeviceName = 32

Private Type RASType
   dwSize As Long
   hRasCon As Long
   szEntryName(RAS_MaxEntryName) As Byte
   szDeviceType(RAS_MaxDeviceType) As Byte
   szDeviceName(RAS_MaxDeviceName) As Byte
End Type

Private Type RASStatusType
   dwSize As Long
   RasConnState As Long
   dwError As Long
   szDeviceType(RAS_MaxDeviceType) As Byte
   szDeviceName(RAS_MaxDeviceName) As Byte
End Type

Private Type RASENTRYNAME95
   dwSize As Long
   szEntryName(RAS_MaxEntryName) As Byte
End Type

Dim DFÜName$

Sub Aufruf()
   Dim sName As String
   sName = WWWAddress("https://www.herber.de")
End Sub
Function WWWAddress(strAddress As String)
   Dim X%
   Dim IP$, DNS$, HOST$
   If Not Online Then Exit Function
   Call InitSockets
   WWWAddress = HostByName(strAddress)
   Call CleanSockets
End Function

Private Sub InitSockets()
   Dim Result%
   Dim LoBy%, HiBy%
   Dim SocketData As WinSocketDataType
   
   Result = WSAStartup(WS_VERSION_REQD, SocketData)
   If Result <> 0 Then
      MsgBox ("'winsock.dll' antwortet nicht !")
      End
   End If
End Sub

Private Function HostByName(Name$, Optional X% = 0) As String
   Dim MemIp() As Byte
   Dim Y%
   Dim HostDeAddress&, HostIp&
   Dim IPAddress$
   Dim HOST As HostDeType
   
   HostDeAddress = gethostbyname(Name)
   If HostDeAddress = 0 Then
      HostByName = ""
      Exit Function
   End If
   
   Call RtlMoveMemory(HOST, HostDeAddress, LenB(HOST))
   
   For Y = 0 To X
      Call RtlMoveMemory(HostIp, HOST.hAddrList + 4 * Y, 4)
      If HostIp = 0 Then
         HostByName = ""
         Exit Function
      End If
   Next Y
   
   ReDim MemIp(1 To HOST.hLength)
   Call RtlMoveMemory(MemIp(1), HostIp, HOST.hLength)
   
   IPAddress = ""
   
   For Y = 1 To HOST.hLength
      IPAddress = IPAddress & MemIp(Y) & "."
   Next Y
   
   IPAddress = Left$(IPAddress, Len(IPAddress) - 1)
   HostByName = IPAddress
End Function

Private Function DFÜStatus() As Boolean
   Dim RAS(255) As RASType, RASStatus As RASStatusType
   Dim lg&, lpcon&, Result&
   
   RAS(0).dwSize = 412
   lg = 256 * RAS(0).dwSize
   Result = RasEnumConnections(RAS(0), lg, lpcon)
   
   If lpcon = 0 Then
      DFÜStatus = False
   Else
      RASStatus.dwSize = 160
      Result = RasGetConnectStatus(RAS(0).hRasCon, RASStatus)
      If RASStatus.RasConnState = &H2000 Then
         DFÜStatus = True
      Else
         DFÜStatus = False
      End If
   End If
End Function

Private Function Online() As Boolean
   Dim Test As Boolean
   Test = DFÜStatus
   If Test = False Then MsgBox _
      ("Keine Online Verbindung vorhanden ! Bitte einwählen !")
      Online = Test
End Function
 
Private Sub CleanSockets()
   Dim Result&
   
   Result = WSACleanup()
   If Result <> 0 Then
      MsgBox ("Socket Error " & Trim$(Str$(Result)) & _
         " in Prozedur 'CleanSockets' aufgetreten !")
      End
   End If
End Sub

Private Function NextChar(Text$, Char$) As String
   Dim POS%
   POS = InStr(1, Text, Char)
   If POS = 0 Then
      NextChar = Text
      Text = ""
   Else
      NextChar = Left$(Text, POS - 1)
      Text = Mid$(Text, POS + Len(Char))
   End If
End Function

    

Beiträge aus dem Excel-Forum zu den Themen Link und Hyperlink