Monday, August 1, 2011

Works fine on my Excel with Userform

Now I have new ms-excel that I’ve copied this codes from Vb-project.com thanks to programer…, I do copy to this:
This description only touches on the most interesting parts of the program. Download it to see the details.You can click the links on the WebBrowser to navigate to a Web page, or enter a URL and click the Go button to navigate there. The following code shows how the program navigates.
Private Sub cmdGo_Click()
    On Error GoTo BadNavigate
    wbrWebSite.Navigate txtUrl.Text
    Exit Sub

BadNavigate:
    MsgBox "Error navigating to web site " & _
        txtUrl.Text & vbCrLf & Err.Description, _
        vbOKOnly Or vbExclamation, "Navigation Error"
End Sub
After you have navigated to the desired Web page, click the Save button to execute the following code.
The code gets the WebBrowser’s Document property, which returns an HtmlDocument object representing the Web page, and loops through the HtmlDocument’s Images collection. It calls subroutine DownloadPicture for each image, passing the routine the image’s src property, which contains the image’s URL.
This routine also contains code to let you stop the loop before it finishes. See the code for details.
Private Sub cmdSaveImages_Click()
Dim doc As HTMLDocument
Dim element As HTMLImg
Dim dir_name As String

    If cmdSaveImages.Caption = "Save" Then
        Me.MousePointer = vbHourglass
        cmdSaveImages.Caption = "Stop"
        cmdGo.Enabled = False
        DoEvents

        ' List the images on this page.
        dir_name = txtDirectory.Text
        If Right$(dir_name, 1) <> "\" Then dir_name = _
            dir_name & "\"

        Set doc = wbrWebSite.Document
        m_Running = True

        For Each element In doc.images
            DownloadPicture dir_name, element.src

            DoEvents
            If Not m_Running Then Exit For
        Next element

        m_Running = False
        cmdSaveImages.Caption = "Save"
        cmdGo.Enabled = True
        Me.MousePointer = vbDefault
        lblFile.Caption = "Done"
        Beep
    Else
        m_Running = False
    End If
End Sub


The DownloadPicture subroutine uses an Internet Transfer Control to download a picture. It calls the control’s OpenURL method to download the image into a byte array. It then opens the appropriate file and writes the bytes into it.
Private Sub DownloadPicture(ByVal dir_name As String, ByVal _
    url As String)
Dim file_title As String
Dim file_name As String
Dim pos As Integer
Dim bytes() As Byte
Dim fnum As Integer

    url = Trim$(url)
    If LCase$(Left$(url, 7)) <> "http://" Then url = _
        "http://" & url

    file_title = url
    pos = InStrRev(file_title, "/")
    If pos > 0 Then file_title = Mid$(file_title, pos + 1)
    file_name = dir_name & file_title

    Debug.Print "Copying " & url & " to " & file_name
    lblFile.Caption = file_title
    lblFile.Refresh

    ' Get the file.
    bytes() = inetDownload.OpenURL(url, icByteArray)    ' Save the file.
    fnum = FreeFile
    Open file_name For Binary Access Write As #fnum
    Put #fnum, , bytes()
    Close #fnum
End Sub

No comments:

Post a Comment