bloodbearer
Grünschnabel
Hallo
Ich habe folgendes Problem:
Ich möchte Daten aus einer HTML auslesen und in Access ausgeben. Problem bei der HTML ist, ich muss auf den Inhalt zugreifen, was ich mit einem String definiere. Aber so ganz funktioniert das noch nicht.
Ich wäre euch sehr dankbar, wenn mir jmd den entscheiden Lösungsvorschlag bringt.
Dazu der Code:
Sitze da nun schon seit wochen dran, um das Problem zu beheben. Bitte helft mir.
Danke
Ich habe folgendes Problem:
Ich möchte Daten aus einer HTML auslesen und in Access ausgeben. Problem bei der HTML ist, ich muss auf den Inhalt zugreifen, was ich mit einem String definiere. Aber so ganz funktioniert das noch nicht.
Ich wäre euch sehr dankbar, wenn mir jmd den entscheiden Lösungsvorschlag bringt.
Dazu der Code:
Visual Basic:
Function getAWB2()
'On Error GoTo ErrHdl
Dim strAWB As String
Dim strURL As String
Dim IEApp As Object, IEDoc As Object
If Not IsNull(DLookup("[ID]", "MSysObjects", "[Name]='tblAWBInfo'")) Then
DoCmd.DeleteObject acTable, "tblAWBInfo"
End If
Set tdf = CurrentDb.CreateTableDef
tdf.Name = "tblAWBInfo"
Set fld = tdf.CreateField("strAWB", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("strInfos", dbMemo)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Checkpoint", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Station", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Location", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Date/Time", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Pcs", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Route", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Cycle", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Stat", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("PgIn", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Count", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Last", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Remarks", dbText, 255)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Comments", dbText, 255)
tdf.Fields.Append fld
CurrentDb.TableDefs.Append tdf
CurrentDb.TableDefs.Refresh
Set rs = CurrentDb.OpenRecordset("tblAWBInfo", dbOpenDynaset)
'strAWB = InputBox("AWB")
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = True
Set rsbold = CurrentDb.OpenRecordset("tblAWB", dbOpenSnapshot)
rsbold.MoveFirst
Do Until rsbold.EOF
strURL = "http://npts2.apis.dhl.com:6010/npts/ShipmentDataFetchServlet?action=14&querycriteria=QUERY_BY_AWB&queryData=" & Trim(rsbold!AWB)
IEApp.Navigate strURL
Do
If UseDoEvents = True Then DoEvents
Loop Until IEApp.Busy = False Or bBreak = True
Set IEDoc = IEApp.Document
Do: Loop Until IEDoc.ReadyState = "complete"
' On Error GoTo ErrHdl1
i = 20
ValNoCP = Trim(Mid(Trim(IEDoc.all.tags("tr").Item(18).innerText), InStr(IEDoc.all.tags("tr").Item(18).innerText, "No of Distinct Checkpoints:") + 27, 3))
'MsgBox(valNoCP)
Do Until i > ValNoCP + 19
'MsgBox (i)
strInfos = Trim(IEApp.Document.all.tags("tr").Item(i).innerHTML)
If strInfos = "" Then
strInfos = " "
End If
rs.AddNew
rs!strAWB = Trim(rsbold!AWB)
rs!strInfos = strInfos
rs.Update
i = i + 1
Loop
rsbold.MoveNext
'ErrHdl1: rsbold.MoveNext
Loop
If IEApp.Visible = True Then
IEApp.Quit
End If
Exit Function
ErrHdl:
MsgBox (Err.Number & ": " & Err.Description)
End Function
Function selectInfo()
Set db = CurrentDb
Set rs = db.OpenRecordset("tblAWBInfo", dbOpenDynaset)
'db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,' class=grayTdNormal', '')"
'db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,' class=whiteTdNormal', '')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,' ', '')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'</A>', '')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'</TD>', '')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'< TD>', '')"
rs.MoveFirst
'strng = Mid(strng, _
' InStr(strng, "</2>") + 20, _
' InStr( _
' InStr(strng, "</2>") + 20, _
' strng, _
' "</2>") _
' - InStr(strng, "</2>") + 20)
'Set rs2 = duba
Do Until rs.EOF
Do While InStr(rs!strInfos, "<") > 0
Strng = rs!strInfos
leftstr = Mid(Strng, InStr(Strng, "<"), 3)
Strng = Replace(Strng, _
Mid(Strng, _
InStr(Strng, "<"), _
InStr(Strng, ">") - InStr(Strng, "<") + 1), _
IIf(leftstr = "<A ", "", IIf(leftstr = "<TD", "[B/]", "KAT")), _
1, 1)
rs.Edit
rs!strInfos = Strng
rs.Update
Loop
rs.MoveNext
Loop
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,chr(10), '')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'>','>')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'<','<')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'&','&')"
rs.MoveFirst
Do Until rs.EOF
i = 0 '0
Do Until i > 12 '11
strig = rs!strInfos
strig = Mid(strig, InStr(strig, "[B/]") + 4, InStr(strig, "[ /E]") - InStr(strig, "[B/]") - 4)
strig = Trim(strig)
If strig = "" Then
strig = " "
End If
rs.Edit
rs(i + 2) = strig
rs.Update
strug = rs!strInfos
strug = Replace(strug, Left(strug, InStr(strug, "[ /E]") + 4), "", 1, 1)
If strug = "" Then
strug = rs!strInfos
End If
rs.Edit
rs!strInfos = strug
rs.Update
i = i + 1
Loop
rs.MoveNext
Loop
rs.Close
db.Close
End Function
Sitze da nun schon seit wochen dran, um das Problem zu beheben. Bitte helft mir.
Danke
Zuletzt bearbeitet von einem Moderator: