Code beschleunigen oder andere Codelogik

x = zum Schluß 716
Satz(1,x) = Name der Unterseite
Satz(2,x) = Position von Name in der Hauptseite
Satz(3,x) = Bezeichnung der Unterseite
Option Base 1
Private Declare Sub InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long)
Private Declare Function InternetOpenA Lib "wininet.dll" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrlA Lib "wininet.dll" ( _
ByVal hOpen As Long, ByVal sUrl As String, _
ByVal sHeaders As String, ByVal lLength As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Sub InternetReadFile Lib "wininet.dll" ( _
ByVal hFile As Long, ByVal sBuffer As String, _
ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long)
'Enumeration für Internet:
Public Enum InternetOpenType
IOTPreconfig = 0
IOTDirect = 1
IOTProxy = 3
End Enum
Sub test()
Dim s As String, n As Integer, a As String, satz(), pos2, ein, x, vorh As Boolean, zei As Long
Dim nn
a = <a href=""http://mypage.bluewin.ch/reprobst/WordFAQ/"">"http://mypage.bluewin.ch/reprobst/WordFAQ/"</a>
s = OpenURL(a)
'WriteFile "c:\temp\inhalt.txt", s
posalt = 2831 'Vorspann weglassen
While posalt <= 73690 'Nachspann weglassen
posneu = InStr(posalt, s, "href")
anz = anz + 1
n = 0
ReDim Preserve satz(3, anz)
While Mid(s, posneu + 6 + n, 1) <> Chr(34)
satz(1, anz) = satz(1, anz) & Mid(s, posneu + 6 + n, 1)
satz(2, anz) = posneu
n = n + 1
Wend
posalt = posneu + 1
Wend
For n = 1 To anz
pos = InStr(satz(2, n), s, "caps")
pos2 = InStr(satz(2, n), s, "</a>")
satz(3, n) = Mid(s, pos + 7, pos2 - pos - 7)
satz(3, n) = Replace(satz(3, n), "</font>", "")
satz(3, n) = Replace(satz(3, n), " ", " ")
Next n
ein = InputBox("Geben Sie die Suchbegriffe ein")
zei = 1
For n = 1 To anz
Application.StatusBar = n & "/716"
s = OpenURL(a & satz(1, n))
x = Split(ein, " ")
vorh = True
For nn = 1 To UBound(x)
If InStr(s, x(nn)) = 0 Then vorh = False
Next nn
If vorh = True Then
zei = zei + 1
Cells(zei, 1) = a & satz(1, n)
Cells(zei, 2) = satz(3, n)
End If
Next n
'For n = 1 To anz
'    Application.StatusBar = n & "/716"
'    s = s & OpenURL(a & satz(1, n))
'Next n
End Sub
Public Function FileExists(Path As String) As Boolean
Const NotFile = vbDirectory Or vbVolume
On Error Resume Next
FileExists = (GetAttr(Path) And NotFile) = 0
On Error GoTo 0
End Function
Function ReadFile(ByRef Path As String) As String
Dim FileNr As Long
'Falls nicht vorhanden, nichts zurückgeben:
On Error Resume Next
If FileLen(Path) = 0 Then Exit Function
On Error GoTo 0
'Datei einlesen:
FileNr = FreeFile
Open Path For Binary As #FileNr
ReadFile = Space$(LOF(FileNr))
Get #FileNr, , ReadFile
Close #FileNr
End Function
Sub WriteFile(ByRef Path As String, ByRef Text As String)
Dim FileNr As Long
'Wenn Datei unverändert, dann abbrechen (ggf. weglassen):
If FileExists(Path) Then _
If FileLen(Path) = Len(Text) Then _
If ReadFile(Path) = Text Then Exit Sub
'Text speichern:
FileNr = FreeFile
Open Path For Output As #FileNr
Print #FileNr, Text;
Close #FileNr
End Sub
Public Function OpenURL( _
ByVal URL As String, _
Optional ByVal OpenType As InternetOpenType = IOTPreconfig _
) As String
Const INET_RELOAD = &H80000000
Dim hInet As Long
Dim hURL As Long
Dim Buffer As String * 2048
Dim Bytes As Long
'Inet-Connection öffnen:
hInet = InternetOpenA( _
"VB-Tec:INET", OpenType, _
vbNullString, vbNullString, 0)
hURL = InternetOpenUrlA( _
hInet, URL, vbNullString, 0, INET_RELOAD, 0)
'Daten sammeln:
Do
InternetReadFile hURL, Buffer, Len(Buffer), Bytes
If Bytes = 0 Then Exit Do
OpenURL = OpenURL & Left$(Buffer, Bytes)
Loop
'Inet-Connection schließen:
InternetCloseHandle hURL
InternetCloseHandle hInet
End Function