'========================================================================================
'- LOOK UP BARCODES ON THE WEB AND GET DESCRIPTION
'- VB Editor Tools/Reference to 'Microsoft Internet Controls' (SHDocVw.dll)
'- InternetExplorer Object : http://msdn.microsoft.com/en-us/library/aa752084(VS.85).aspx
'----------------------------------------------------------------------------------------
'- EXTRACTS THE PAGE HTML TEXT AS A STRING (can avoid "Access Denied" with other methods)
'- Method : Format column A as text and list codes A2 down. Run the macro.
'- Additional data in a field means that an extra data type is required in array Arr1()
'- #### This is the only action required. #######
'- Brian Baulsom July 2010. Excel 2003.
'========================================================================================
'- Worksheet
Dim ws As Worksheet
Dim BarCode As String
Dim MyRow As Long
Dim MyCol As Integer
Dim LastRow As Long
Dim Counter As Integer
'----------------------------------------------------------------
'- Get Web Page
Const MyBaseURL As String = "http://www.upcdatabase.com/item/"
Dim IE As SHDocVw.InternetExplorer
Dim MyURL As String
Dim LoadTimeOut As Integer ' web page timeout 10 seconds
Dim LoadTimer As Integer ' seconds counter
Dim rsp As Variant ' message box
Dim Success As Integer ' count successes
'-----------------------------------------------------------------
'- Page Content
Dim PageString As String
Dim MyRegExp As Object
Dim MyMatches As Object
Dim Arr1() ' array of data items
Dim Arr2() ' data item positions in the string
Dim N1, N2, C1, C2 ' data string extract pointers
Dim DataValue As String
'----------------------------------------------------------------------------------------
'========================================================================================
'- MAIN ROUTINE TO GET LOOKUP VALUE FROM WORKSHEET
'- Barcodes are in column A
'========================================================================================
Sub BARCODE_LOOKUP()
Application.Calculation = xlCalculationManual
'####################################################################################
'- SHEET HEADERS & DATA ITEM LIST
'- ADD NEW ITEMS HERE. EXACT TEXT. IN CORRECT ORDER.
'-------------------------------------------------------------------------------------
Arr1() = Array("Bar Code", "Description", "Size/Weight", "Owner GLN", "Owner Name", _
"Owner Address", "Issuing Country", "Last Modified", "Last modified by", _
"Pending Updates")
'####################################################################################
ReDim Arr2(UBound(Arr1) + 1)
LoadTimeOut = 10 ' 10 seconds
Set MyRegExp = CreateObject("VbScript.RegExp")
'-----------------------------------------------------------------------------------
Set ws = ActiveSheet
ws.Range(Cells(1, "A"), Cells(1, UBound(Arr1))) = Arr1()
LastRow = ws.Range("A65536").End(xlUp).Row
Counter = LastRow - 1
Success = 0
'=================================================================================
'- LOOP WORKSHEET ROWS
For MyRow = 2 To LastRow
PageString = ""
BarCode = CStr(ws.Cells(MyRow, "A").Value)
MyURL = MyBaseURL & BarCode
'==============================================
GET_WEB_PAGE ' subroutine
'==============================================
'- CHECK FOR ERRORS IN THE PAGE
If InStr(1, PageString, "Item not found", vbTextCompare) > 0 Then
ws.Cells(MyRow, 2).Value = "Item not found"
ElseIf InStr(1, PageString, "incorrect or invalid", vbTextCompare) > 0 Then
ws.Cells(MyRow, 2).Value = "Invalid number"
Else
If rsp = vbCancel Then Exit For
If rsp = "web page error" Then GoTo NextLine
'-------------------------------------------
GET_PAGE_CONTENT ' subroutine
'-------------------------------------------
End If
'===============================================
Application.Wait Now + TimeValue("00:00:02")
NextLine:
Next
'-----------------------------------------------------------------------------------
MsgBox ("Completed " & Success & " of " & Counter & " records." _
& IIf(rsp = vbCancel, vbCr & "Cancelled by user", ""))
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub
'========== END OF MAIN =================================================================
'========================================================================================
'- SUBROUTINE : GET WEB PAGE
'- Visible property set False so it runs in the background.
'- StatusBar shows progress.
'- Timeout set to 10 seconds above
'========================================================================================
Private Sub GET_WEB_PAGE()
LoadTimer = 0
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
'--------------------------------------------------------------------------------
On Error Resume Next
.navigate MyURL
Do Until (.readyState = READYSTATE_COMPLETE) Or (LoadTimer >= LoadTimeOut)
Application.StatusBar = MyRow - 1 & " of " & Counter & " : " _
& BarCode & " " & LoadTimer & " seconds."
Application.Wait Now + TimeValue("0:00:01") ' WAIT 1 SECOND
LoadTimer = LoadTimer + 1
DoEvents
Loop
On Error GoTo GetOut
'--------------------------------------------------------------------------------
'- PAGE TO STRING
PageString = CStr(.Document.Body.innerhtml)
'--------------------------------------------------------------------------------
'- CLOSE IE
.Quit
'--------------------------------------------------------------------------------
'- TIMEOUT MESSAGE
If LoadTimer >= LoadTimeOut Then
rsp = MsgBox("The web page indicated in the statusbar has timed out" & vbCr _
& "OK to try the next one", vbOKCancel)
If rsp = vbCancel Then Exit Sub
Else
Success = Success + 1
End If
'--------------------------------------------------------------------------------
End With
Set IE = Nothing
Exit Sub
'-----------------------------------------------------------------------------------
GetOut:
MsgBox ("Error loading web page")
rsp = "web page error"
End Sub
'========== EOP =========================================================================
'========================================================================================
'- SUBROUTINE : GET PAGE CONTENT
'- REGULAR EXPRESSIONS TO EXTRACT DATA FROM THE PAGE STRING
'========================================================================================
Private Sub GET_PAGE_CONTENT()
Dim C1, C2 ' string start/finish character positions
'------------------------------------------------------------------------------------
'- STAGE 1 : EXTRACT JUST THE DATA TABLE
With MyRegExp
.Global = True
.ignorecase = True
.Pattern = "Description[\s\S]*/table"
Set MyMatches = .Execute(PageString) ' zero based array
End With
'------------------------------------------------------------------------------------
PageString = MyMatches(0)
'====================================================================================
'- STAGE 2 : EXTRACT DATA ONLY (remove tags etc.) = new PageString
With MyRegExp
.Global = True
.ignorecase = True
.Pattern = "<TR>|<TD>|</TD>|<TR>|</TR>|&#.*;|</TBODY>|</TABLE"< p> PageString = .Replace(PageString, "")
End With
'====================================================================================
'- STAGE 3 : DATA TO WORKSHEET
'- Data Positions to array
For n = 1 To (UBound(Arr1))
Arr2(n) = InStr(1, PageString, Arr1(n), vbTextCompare)
Next
Arr2(UBound(Arr2)) = Len(PageString) + 1
'------------------------------------------------------------------------------------
MyCol = 2
N1 = 1
N2 = 2
'------------------------------------------------------------------------------------
While N1 <= UBound(Arr1)
C1 = Arr2(N1) ' first character
If C1 <> 0 Then
Do
C2 = Arr2(N2) ' next item start
N2 = N2 + 1
Loop While C2 = 0
DataValue = Mid(PageString, C1, C2 - C1)
DataValue = "'" _
& Trim(Application.WorksheetFunction.Clean(Mid(PageString, C1 _
+ Len(Arr1(N1)), C2 - C1 - Len(Arr1(N1)))))
Else
DataValue = "n/a"
End If
'-------------------------------------------------------------------------------
'- TO WORKSHEET
ActiveSheet.Cells(MyRow, MyCol).Value = DataValue
MyCol = MyCol + 1
N1 = N1 + 1
'-------------------------------------------------------------------------------
Wend
End Sub
'========== eop ========================================================================
ffice
