Making a bing search result grabber(help)

Microsoft Visual basic enterprise ed 6.0...
October 7, 2009 at 16:16:24
Specs: Windows XP
Hi guys,
I try to make a simple bing search result grabber like this:

My codes:(This codes for google)
-----------------------------------------------------
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim bStop As Boolean

Private Sub cmdSubmit_Click()
'...
Dim iCounter As Integer, sSite As String
Select Case cmdSubmit.Caption
Case "submit"
If Len(Trim$(txtQuery.Text)) Then
bStop = False
cmdSubmit.Caption = "cancel"
fraSettings.Enabled = False
For iCounter = 1 To Val(cboPages.Text)
If bStop Then Exit For
lblStatus.Caption = "grabbing page " & iCounter & " of " & Val(cboPages.Text)
DoEvents
sSite = GetSite("http://google." & cboDomain.Text & "/search?q=" & txtQuery.Text & "&num=" & cboResults.Text & "&lr=lang_" & cboLanguage.Text & "&start=" & ((iCounter - 1) * Val(cboResults.Text)))
If Len(sSite) Then GetURLs sSite
Next iCounter
cmdSubmit.Caption = "submit"
fraSettings.Enabled = True
lblStatus.Caption = vbNullString
MsgBox "done!" & vbCrLf & lstResults.ListCount & " urls in list", vbInformation
Else
MsgBox "you must enter a query!", vbExclamation
End If
Case "cancel"
bStop = True
End Select
End Sub

Private Function GetSite(ByVal sURL As String)
On Error GoTo Err
'returns a sites content
Dim sBuffer As String, sResult As String
With Inet
.Execute sURL, "GET", , "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1.3) Gecko/20070309 Firefox/2.0.0.3"
While .StillExecuting
DoEvents
Wend
Do
DoEvents
sBuffer = .GetChunk(1024, icString)
sResult = sResult & sBuffer
Loop While Len(sBuffer)
GetSite = sResult
End With
Exit Function
Err:
GetSite = vbNullString
End Function

Private Sub GetURLs(ByVal sText As String)
'collects all strings between href=" and " ; adding them to list
Dim lPos As Long, lStartPos As Long, lEndPos As Long, sFound As String
If Len(sText) Then
Do
lPos = InStr(lPos + 1, LCase$(sText), "href=" & Chr$(34))
If lPos Then
lStartPos = lPos + 6
lPos = InStr(lStartPos + 1, sText, Chr$(34))
If lPos Then
lEndPos = lPos
sFound = Mid$(sText, lStartPos, lEndPos - lStartPos)
If IsGoodURL(sFound) And Not IsInlist(sFound) Then lstResults.AddItem sFound
End If
End If
Loop While lPos
End If
End Sub

Private Function IsGoodURL(ByVal sURL As String)
'looks for unimportant google urls
If InStr(1, Left$(sURL, 12), "://") And InStr(1, sURL, "accounts/Login?continue") = 0 And InStr(1, sURL, "webhp?hl=") = 0 And InStr(1, sURL, "images.google") = 0 And InStr(1, sURL, "groups.google") = 0 And InStr(1, sURL, "news.google") = 0 And InStr(1, sURL, "froogle.google") = 0 And InStr(1, sURL, "translate.google") = 0 And InStr(1, sURL, "video.google") = 0 And InStr(1, sURL, "blogsearch.google") = 0 And InStr(1, sURL, "books.google") = 0 And InStr(1, sURL, "maps.google") = 0 And InStr(1, sURL, "search?q=cache") = 0 And InStr(1, sURL, "patents?q=") = 0 Then IsGoodURL = True
End Function

Private Sub Command1_Click()
Dim iCounter As Integer, F As Integer
F = FreeFile
Open GetAppPath & "urls.txt" For Output As #F
For iCounter = 0 To lstResults.ListCount - 1
Print #F, lstResults.List(iCounter)
Next iCounter
Close #F
MsgBox "urls saved to " & GetAppPath & "urls.txt", vbInformation
End Sub

Private Sub Form_Load()
'sets default values for the comboboxes
cboDomain.ListIndex = 0
cboLanguage.ListIndex = 0
cboResults.ListIndex = 0
cboPages.ListIndex = 0
End Sub

Private Function IsInlist(sText As String) As Boolean
'checks if item is already in list
IsInlist = IIf(SendMessage(lstResults.hwnd, &H1A2, -1, sText) = -1, False, True)
End Function

Private Sub lstResults_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'popup menĂ¼
If Len(lstResults.Text) Then Me.PopupMenu mnuFile
End Sub

Private Sub mnuClear_Click()
'...
lstResults.Clear
End Sub

Private Sub mnuCopy_Click()
'copies selected url
With Clipboard
.Clear
.SetText lstResults.Text
End With
End Sub

Private Sub mnuOpen_Click()
'opens selected url in standard browser
ShellExecute Me.hwnd, "open", lstResults.Text, vbNullString, GetAppPath, vbNormalFocus
End Sub

Private Function GetAppPath()
'returns app. path + \
GetAppPath = App.Path & IIf(Right(App.Path, 1) <> "\", "\", "")
End Function

Private Sub mnuRemove_Click()
'removes selected item
With lstResults
.RemoveItem .ListIndex
End With
End Sub

Private Sub mnuSave_Click()
'saves the list
Dim iCounter As Integer, F As Integer
F = FreeFile
Open GetAppPath & "urls.txt" For Output As #F
For iCounter = 0 To lstResults.ListCount - 1
Print #F, lstResults.List(iCounter)
Next iCounter
Close #F
MsgBox "urls saved to " & GetAppPath & "urls.txt", vbInformation
End Sub

---------------------------------------------

How can I apply this codes for bing search result?
Can you help me?

Thanks.


See More: Making a bing search result grabber(help)

Report •


#1
October 8, 2009 at 02:12:47
ANy body can help me?

Report •

#2
October 8, 2009 at 05:46:08
Probably not, no.

I seem to be the only one here who responds to VB* threads, and I don't work with VB6.


Report •

Related Solutions


Ask Question