Gruppe
Link
Problem
In einem neuen Tabellenblatt sollen die Hyperlinks mit der Angabe, ob die Datei bzw. die Webseite existiert, gelistet werden.
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