Import data from html to access
hello
I've got a problem and i'm sitting since several weeks at it.
I want to read the information in a html and export it in an accesstable.
this is my code but it didn't run.
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=Q UERY_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).innerT ext), 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).innerHT ML)
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>', '[/E]')"
db.Execute "UPDATE tblAWBInfo SET tblAWBInfo.strInfos = Replace(tblAWBInfo.strInfos,'< TD>', '[/E]')"
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
I write in the table tblAWB several (10digits long) AWB and the module should export the information for this AWBs from their html site in an access table.
please be so kind and help me.
thanks
