Nice Excel

Works fine on my Excel with Userform

No 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

This program still has a few weak spots. For example, it doesn’t display previews of the images so it doesn’t let you pick the images you want to download, it just downloads them all. The .NET version of this program does a better job of letting you pick images for download.The program also downloads images when it needs them rather than pulling them from cache so it isn’t as fast as it might be. It also probably cannot save images that are generated on the fly by the Web server.