Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
724to728
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Fehler 5 bei Hyperlinks.Add

Fehler 5 bei Hyperlinks.Add
28.01.2006 18:28:54
Reinhard
Hallo Wissende,
ich habe schon ws1.activate eingebaut und ws2 nochmals referenziert obwohl es schon in einer With ws2 Schleife passiert.
Nachfolgende der ganze Code.
Ich musste "h ttp" so schreiben weil sonst die Anzeige zu breit geworden wäre hier im Forum.
Der Fehler kommt in der Hperlinks.Add-Zeile:

ws1.Activate
Range("a1") = ws1.Cells(zei1, sp).Address
Range("a2") ="h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & ws2.Cells(nn, 2)
Range("a3") = ws2.Cells(nn, 3)
ActiveSheet.Hyperlinks.Add Anchor:=ws1.Cells(zei1, sp), _
Address:="h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & ws2.Cells(nn, 2), _
TextToDisplay:=ws2.Cells(nn, 3)

In den Zellen steht:
A1: $A$1
A2: h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=3339612
A3: test
Und wenn ich den Inhalt von A2 im Browser aufrufe wird die Seite korrekt angezeigt.
Wo liegt der Fehler?
Danke und Gruß
Reinhard
Option Explicit
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
Dim Alt As String, anz As Long
Sub Neuerungen()
Call Einlesen
Call Vergleich
End Sub
Sub Einlesen()
Dim Neu As String, n As Integer, ein As String, strURL, gef(), gef2(), z2 As Long
Dim pos As Long, such As String, z As Long, zei As Long, adr As String
Dim Satz, Artikel(), ArtID(), Betreff(), NameDatum()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
Set ws3 = Worksheets("Tabelle3")
Columns("A:H").Clear
Application.ScreenUpdating = False
strURL = "h ttp://www.wer-weiss-was.de/cgi-bin/forum/board.fpl?op=Anzeige&ThemenID=156"
Neu = OpenURL(strURL)
Satz = Split(Neu, Chr(10))
For n = 1 To UBound(Satz)
If Left(Satz(n), 3) = "<ul" Or Left(Satz(n), 3) = "<li" Then
anz = anz + 1
ReDim Preserve Artikel(anz)
ReDim Preserve ArtID(anz)
ReDim Preserve Betreff(anz)
ReDim Preserve NameDatum(anz)
pos = InStr(Satz(n), "class=") + 7
While Mid(Satz(n), pos, 1) <> Chr(34)
Artikel(anz) = Artikel(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
pos = InStr(Satz(n), "ArtikelID=") + 10
While Mid(Satz(n), pos, 1) <> Chr(34)
ArtID(anz) = ArtID(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
pos = pos + 2
If InStr(Satz(n), "<font class=""artikelgrau"">") = 0 Then
While Mid(Satz(n), pos, 4) <> "</A>"
Betreff(anz) = Betreff(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
pos = pos + 5
While Mid(Satz(n), pos, 1) <> ")"
NameDatum(anz) = NameDatum(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
Else
pos = InStr(Satz(n), "<font class=""artikelgrau"">") + 25
While Mid(Satz(n), pos, 7) <> "</font>"
Betreff(anz) = Betreff(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
pos = InStrRev(Satz(n), "(") 'Instrrev gabs bei Exycel97 noch nicht
While Mid(Satz(n), pos, 1) <> ")"
NameDatum(anz) = NameDatum(anz) & Mid(Satz(n), pos, 1)
pos = pos + 1
Wend
NameDatum(anz) = NameDatum(anz) & ")"
End If
Betreff(anz) = Left(Betreff(anz), Len(Betreff(anz)) - 1)
Betreff(anz) = Replace(Betreff(anz), "<font color=""#008800"">", "")
Betreff(anz) = Replace(Betreff(anz), "<B>", "")
Betreff(anz) = Replace(Betreff(anz), "</B", "")
Betreff(anz) = Replace(Betreff(anz), "</font>", "")
Betreff(anz) = Replace(Betreff(anz), "</font", "")
If Left(Betreff(anz), 1) = ">" Then Betreff(anz) = Mid(Betreff(anz), 2)
ws2.Cells(anz, 1) = Artikel(anz)
ws2.Cells(anz, 2) = ArtID(anz)
ws2.Cells(anz, 3) = Betreff(anz)
ws2.Cells(anz, 4) = NameDatum(anz)
End If
Next n
For n = anz To 2 Step -1 'warum auchbimmer sind manche mehrfach im Htmlcode
If Application.WorksheetFunction.CountIf(ws2.Range("B1:B" & anz), ws2.Cells(n, 2)) > 1 Then
ws2.Cells(n, 2).EntireRow.Delete
anz = anz - 1
End If
Next n
If ws3.Range("A1") = "" Then 'erstmalige Benutzung
ws2.Range("A1:H" & anz).Copy ws3.Range("A1")
End If
ws2.Columns("A:H").AutoFit
ws3.Columns("A:H").AutoFit
Application.ScreenUpdating = True
End Sub
Sub Vergleich()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, zei3 As Long, n As Long, dummy
Dim pos As Long, anzahl As Integer, von As Long, bis As Long, zei1 As Long, sp As Byte
Dim nn As Long
On Error GoTo Ausgabe
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
Set ws3 = Worksheets("Tabelle3")
zei3 = ws3.Range("B65536").End(xlUp).Row
ws1.UsedRange.Clear
With ws2
For n = 1 To anz
dummy = Application.WorksheetFunction.VLookup(.Cells(n, 2), ws3.Range("B1:B" & zei3), 1, 0)
Next n
Exit Sub
Ausgabe:
pos = n
anzahl = anzahl + 1
While .Cells(pos, 1) <> "article"
pos = pos - 1
Wend
von = pos
If Application.WorksheetFunction.CountIf(ws1.Columns("A"), .Cells(von, 2)) > 0 Then Resume Next
pos = n + 1
While .Cells(pos, 1) <> "article" And .Cells(pos, 1) <> ""
pos = pos + 1
Wend
bis = pos - 1
If ws1.Cells(1, 1) = "" Then zei1 = 0
For nn = von To bis
Select Case .Cells(nn, 1)
Case "article"
sp = 1
Case "sart"
sp = sp + 1
Case Else
End Select
zei1 = zei1 + 1
ws1.Activate
Range("a1") = ws1.Cells(zei1, sp).Address
Range("a2") = "h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & ws2.Cells(nn, 2)
Range("a3") = ws2.Cells(nn, 3)
ActiveSheet.Hyperlinks.Add Anchor:=ws1.Cells(zei1, sp), _
Address:="h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & ws2.Cells(nn, 2), _
TextToDisplay:=ws2.Cells(nn, 3)
'    ws1.Cells(zei1, sp) = .Cells(nn, 2)
If n = nn Then
ws1.Cells(zei1, sp).Interior.ColorIndex = 34
End If
Next nn
Resume Next
End With
End Sub
Sub Minus()
Dim n As Long
Application.ScreenUpdating = False
For n = 1 To Range("C65536").End(xlUp).Row
If Cells(n, 2) = "" Then Cells(n, 2).EntireRow.Hidden = True
Next n
Application.ScreenUpdating = True
End Sub
Sub Plus()
Dim n As Long
Application.ScreenUpdating = False
Rows("1:" & Range("C65536").End(xlUp).Row).Hidden = False
Application.ScreenUpdating = True
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 * 8096
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Jetzt kommt Fehler 13
28.01.2006 18:49:01
Reinhard
Hallo,
nach Codeänderung (.Address, CStr) kommt jetzt Fehler 13.
ws1.Activate
Range("a1") = ws1.Cells(zei1, sp).Address
Range("a2") = "h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & ws2.Cells(nn, 2)
Range("a3") = ws2.Cells(nn, 3)
x = ws1.Cells(zei1, sp).Address
'x = Replace(ws1.Cells(zei1, sp).Address, "$", "")
ActiveSheet.Hyperlinks.Add Anchor:=x, _
Address:="h ttp://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & CStr(ws2.Cells(nn, 2)), _
TextToDisplay:=ws2.Cells(nn, 3)
Gruß
Reinhard
ps:Das Forum lebt auch von Rückmeldungen.
Anzeige
Problem gelöst :-)
28.01.2006 23:48:47
Reinhard
Hallo Interessierte,
mit Typename fand ich es heraus, bei "TextToDisplay" war .Cells(nn, 3) unzureichend, .Cells(nn, 3).Value war nötig. So klappt es:
ActiveSheet.Hyperlinks.Add Anchor:=ws1.Cells(zei1, sp), _
Address:="http://www.wer-weiss-was.de/cgi-bin/forum/showarticle.fpl?ArtikelID=" & CStr(ws2.Cells(nn, 2)), _
TextToDisplay:=.Cells(nn, 3).Value
Gruß
Reinhard

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige