Webbrowser, Convert HTML to image
in [Visual Basic]
|
From: Eduardo on 22 Sep 2009 16:17 Mike Williams escribi�: > The VB6 WebBrowser Control would probably present a problem though, > because that too is limited to 16383 pixels, although I imagine you > could get around that one Hi again: I changed the code to split the page into several images. You need to add a textbox to the form (it will be used to enter the desired height of the image). This solves the page length issue. Here is the new code: 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 Long) As Long Private Declare Function GetWindow Lib "user32" _ (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function GetClassName Lib "user32" _ Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, ByVal nMaxCount As Long) _ As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Const WM_PAINT = &HF Private Const WM_PRINT = &H317 Private Const PRF_CHILDREN = &H10& Private Const PRF_CLIENT = &H4& Private Const PRF_OWNED = &H20& Private Const GW_CHILD = 5 Private Const GW_HWNDNEXT = 2 Private Const SM_CXVSCROLL = 2 Private mMaxImageHeight As Long Private Sub Command1_Click() WebBrowser1.Navigate "http://www.freevbcode.com/ShowCode.Asp?ID=1287" 'WebBrowser1.Navigate "http://www.google.com" 'WebBrowser1.Navigate "http://www.yahoo.co.uk" Caption = "Loading page . . ." End Sub Private Sub Form_Load() Picture1.BorderStyle = vbBSNone Picture1.AutoRedraw = True Picture1.Visible = False Me.ScaleMode = vbTwips Caption = "Enter desired image height and " & _ "click the button to load the page . . ." Text1.Text = "5000" End Sub Private Sub SaveWebBrowserPicture(nFile As String) Dim myWindow As Long, childWindow As Long Dim myClass As String, clsName As String * 256 Dim s1 As String Dim iP As StdPicture Command1.SetFocus myClass = "Shell Embedding" childWindow = GetWindow(Me.hwnd, GW_CHILD) Do GetClassName childWindow, clsName, 256 If Left$(clsName, Len(myClass)) = myClass Then myWindow = childWindow Exit Do End If childWindow = GetWindow(childWindow, GW_HWNDNEXT) Loop While childWindow <> 0 If myWindow <> 0 Then SendMessage myWindow, WM_PAINT, Picture1.hDC, 0 SendMessage myWindow, WM_PRINT, Picture1.hDC, _ PRF_CHILDREN + PRF_CLIENT + PRF_OWNED Set iP = Picture1.Image Picture1.Cls Picture1.Width = Picture1.Width - ScaleX(4, vbPixels, vbTwips) Picture1.Height = Picture1.Height - ScaleY(4, vbPixels, vbTwips) Picture1.PaintPicture iP, 0, 0, , , ScaleX(2, vbPixels, vbTwips), _ ScaleY(2, vbPixels, vbTwips), Picture1.Width, Picture1.Height Picture1.Picture = Picture1.Image s1 = "d:\" & nFile & ".bmp" ' or whatever is required Caption = "Saving image file " & s1 SavePicture Picture1.Picture, s1 Set Picture1.Picture = Nothing Picture1.Cls Picture1.Width = Picture1.Width + ScaleX(4, vbPixels, vbTwips) Picture1.Height = Picture1.Height + ScaleY(4, vbPixels, vbTwips) End If End Sub Private Sub Text1_Change() If Val(Text1.Text) > 16379 Then Text1.Text = "16379" If Val(Text1.Text) < 600 Then Text1.Text = "600" mMaxImageHeight = Val(Text1.Text) End Sub Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As _ Object, URL As Variant) Dim iWidth As Long Dim iHeight As Long Dim iBody As Object Dim iImageNumber As Long Dim iScrollBarWidth As Long If URL = WebBrowser1.LocationURL And Len(URL) > 8 Then Set iBody = WebBrowser1.Document.Body iScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL) iWidth = iBody.ScrollWidth If iWidth < 800 Then iWidth = 800 If iWidth > Screen.Width / Screen.TwipsPerPixelX _ * 3 Then iWidth = Screen.Width / _ Screen.TwipsPerPixelX * 3 iWidth = iWidth + iScrollBarWidth + 4 iHeight = iBody.ScrollHeight If iHeight < 600 Then iHeight = 600 WebBrowser1.Width = ScaleX(iWidth, vbPixels, vbTwips) Picture1.Width = WebBrowser1.Width - _ ScaleX(iScrollBarWidth, vbPixels, vbTwips) Do Until mMaxImageHeight * iImageNumber >= iBody.ScrollHeight If iBody.ScrollHeight > mMaxImageHeight Then If mMaxImageHeight * (iImageNumber + 1) > _ iBody.ScrollHeight Then WebBrowser1.Height = ScaleY(iBody.ScrollHeight - _ mMaxImageHeight * iImageNumber + 4, vbPixels, _ vbTwips) iBody.ScrollTop = mMaxImageHeight * iImageNumber Else iBody.ScrollTop = mMaxImageHeight * iImageNumber WebBrowser1.Height = ScaleY(mMaxImageHeight + 4, _ vbPixels, vbTwips) End If Else WebBrowser1.Height = ScaleY(iHeight + 4, vbPixels, _ vbTwips) End If Picture1.Height = WebBrowser1.Height iImageNumber = iImageNumber + 1 SaveWebBrowserPicture "webpic" & iImageNumber Loop Caption = "Done" End If End Sub
From: Eduardo on 22 Sep 2009 16:20 Shotgun Thom escribi�: > Perfect, Eduardo. That's exactly what I was looking for in regards to > sizing. Thank you! > > Tom You are welcome. Look at the new message in response to Mike Williams. It is new code, and it's able to split large pages into several images.
From: Mike Williams on 22 Sep 2009 17:29 "Eduardo" <mm(a)mm.com> wrote in message news:h9bbcq$9g2$1(a)aioe.org... > Hi again: I changed the code to split the page into > several images. You need to add a textbox to the > form (it will be used to enter the desired height of > the image). This solves the page length issue. That looks good, Eduardo. There may be some problems with it as it stands though (unless I am making a mistake somewhere . . . it's getting a bit late in the evening!). I ran it using the default 5000 pixels on a fairly long web page (which needed about three pages) and they didn't quite match (there was about a screen height of data missing between the bottom of the first bmp and the top of the second). I then tried it on the yahoo.co.uk page using a pixel setting in the TextBox of 600 and it produced two bitmaps totaling approximately the correct height (the first 600 pixels high and the second 474 pixels high) but they were both of the top portion of the page. The lower portion of the page was not saved at all. I then tried it on the very long page linked by Olaf Schmidt and it produced lots of pages (because it is very long) but all of them were the same (the top portion of the page). I tried it on other web pages and I'm sure that it seemed to work fine on some of them, but I'm not really fully awake at the moment (!) and so I can't recall the details. So, unless I have been doing something wrong the code has some issues that need resolving, although personally I think it might be a timing problem rather than a logic problem in the code (I haven't checked that out yet). I'll give it another try tomorrow, when I will be fully awake! Once these problems are fixed though (if they really are problems) it looks like it will be very useful code. When it has been fully tested you might even want to look into stitching the bitmaps together into one very long bitmap (if of course you think one very long bitmap might actually be a desirable option). You can easily do that by blitting each individual bitmap produced by the code into one very long bitmap (preferably a DIBSection). Mike
From: Eduardo on 22 Sep 2009 21:28 Mike Williams escribi�: > That looks good, Eduardo. There may be some problems with it as it > stands though (unless I am making a mistake somewhere . . . it's getting > a bit late in the evening!). I ran it using the default 5000 pixels on a > fairly long web page (which needed about three pages) and they didn't > quite match (there was about a screen height of data missing between the > bottom of the first bmp and the top of the second). I then tried it on > the yahoo.co.uk page using a pixel setting in the TextBox of 600 and it > produced two bitmaps totaling approximately the correct height (the > first 600 pixels high and the second 474 pixels high) but they were both > of the top portion of the page. The lower portion of the page was not > saved at all. I then tried it on the very long page linked by Olaf > Schmidt and it produced lots of pages (because it is very long) but all > of them were the same (the top portion of the page). I tried it on other > web pages and I'm sure that it seemed to work fine on some of them, but > I'm not really fully awake at the moment (!) and so I can't recall the > details. So, unless I have been doing something wrong the code has some > issues that need resolving, although personally I think it might be a > timing problem rather than a logic problem in the code (I haven't > checked that out yet). I'll give it another try tomorrow, when I will be > fully awake! Once these problems are fixed though (if they really are > problems) it looks like it will be very useful code. When it has been > fully tested you might even want to look into stitching the bitmaps > together into one very long bitmap (if of course you think one very long > bitmap might actually be a desirable option). You can easily do that by > blitting each individual bitmap produced by the code into one very long > bitmap (preferably a DIBSection). It was hard to find a solution. Seemingly there is a bug with the Body.ScrollTop property. It works fine with some pages and it doesn't work with other pages. I found the Body.setExpression method that is for scripting, and the ScrollTo method not exposed in the COM interface. So, Body.ScrollTop = Value become iBody.setExpression "ScrollTo", "ScrollTo (0, " & Value & ")" _ , "vbScript" Here is the full code again: '************************* 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 Long) As Long Private Declare Function GetWindow Lib "user32" _ (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function GetClassName Lib "user32" _ Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, ByVal nMaxCount As Long) _ As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Const WM_PAINT = &HF Private Const WM_PRINT = &H317 Private Const PRF_CHILDREN = &H10& Private Const PRF_CLIENT = &H4& Private Const PRF_OWNED = &H20& Private Const GW_CHILD = 5 Private Const GW_HWNDNEXT = 2 Private Const SM_CXVSCROLL = 2 Private mMaxImageHeight As Long Private Sub Command1_Click() WebBrowser1.Navigate "http://www.slashdot.org" 'WebBrowser1.Navigate "http://www.freevbcode.com/ShowCode.Asp?ID=1287" 'WebBrowser1.Navigate "http://www.google.com" 'WebBrowser1.Navigate "http://www.yahoo.co.uk" Caption = "Loading page . . ." End Sub Private Sub Form_Load() Picture1.BorderStyle = vbBSNone Picture1.AutoRedraw = True Picture1.Visible = False Me.ScaleMode = vbTwips Caption = "Enter desired image height and " & _ "click the button to load the page . . ." Text1.Text = "5000" End Sub Private Sub SaveWebBrowserPicture(nFile As String) Dim myWindow As Long, childWindow As Long Dim myClass As String, clsName As String * 256 Dim s1 As String Dim iP As StdPicture Command1.SetFocus myClass = "Shell Embedding" childWindow = GetWindow(Me.hwnd, GW_CHILD) Do GetClassName childWindow, clsName, 256 If Left$(clsName, Len(myClass)) = myClass Then myWindow = childWindow Exit Do End If childWindow = GetWindow(childWindow, GW_HWNDNEXT) Loop While childWindow <> 0 If myWindow <> 0 Then SendMessage myWindow, WM_PAINT, Picture1.hDC, 0 SendMessage myWindow, WM_PRINT, Picture1.hDC, _ PRF_CHILDREN + PRF_CLIENT + PRF_OWNED Set iP = Picture1.Image Picture1.Cls Picture1.Width = Picture1.Width - ScaleX(4, vbPixels, vbTwips) Picture1.Height = Picture1.Height - ScaleY(4, vbPixels, vbTwips) Picture1.PaintPicture iP, 0, 0, , , ScaleX(2, vbPixels, vbTwips), _ ScaleY(2, vbPixels, vbTwips), Picture1.Width, Picture1.Height Picture1.Picture = Picture1.Image s1 = "d:\" & nFile & ".bmp" ' or whatever is required Caption = "Saving image file " & s1 SavePicture Picture1.Picture, s1 Set Picture1.Picture = Nothing Picture1.Cls Picture1.Width = Picture1.Width + ScaleX(4, vbPixels, vbTwips) Picture1.Height = Picture1.Height + ScaleY(4, vbPixels, vbTwips) End If End Sub Private Sub Text1_Change() If Val(Text1.Text) > 16379 Then Text1.Text = "16379" If Val(Text1.Text) < 600 Then Text1.Text = "600" mMaxImageHeight = Val(Text1.Text) End Sub Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As _ Object, URL As Variant) Dim iWidth As Long Dim iHeight As Long Dim iBody As Object Dim iImageNumber As Long Dim iScrollBarWidth As Long If URL = WebBrowser1.LocationURL And Len(URL) > 8 Then Set iBody = WebBrowser1.Document.body iScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL) iWidth = iBody.ScrollWidth If iWidth < 800 Then iWidth = 800 If iWidth > Screen.Width / Screen.TwipsPerPixelX _ * 3 Then iWidth = Screen.Width / _ Screen.TwipsPerPixelX * 3 iWidth = iWidth + iScrollBarWidth + 4 iHeight = iBody.ScrollHeight If iHeight < 600 Then iHeight = 600 WebBrowser1.Width = ScaleX(iWidth, vbPixels, vbTwips) Picture1.Width = WebBrowser1.Width - _ ScaleX(iScrollBarWidth, vbPixels, vbTwips) Do Until mMaxImageHeight * iImageNumber >= iBody.ScrollHeight If iBody.ScrollHeight > mMaxImageHeight Then If mMaxImageHeight * (iImageNumber + 1) > _ iBody.ScrollHeight Then WebBrowser1.Height = ScaleY(iBody.ScrollHeight - _ mMaxImageHeight * iImageNumber + 4, vbPixels, _ vbTwips) iBody.setExpression "ScrollTo", "ScrollTo (0, " _ & mMaxImageHeight * iImageNumber & ")", _ "vbScript" Else iBody.setExpression "ScrollTo", "ScrollTo (0, " _ & mMaxImageHeight * iImageNumber & ")", _ "vbScript" WebBrowser1.Height = ScaleY(mMaxImageHeight + 4, _ vbPixels, vbTwips) End If Else WebBrowser1.Height = ScaleY(iHeight + 4, vbPixels, _ vbTwips) End If Picture1.Height = WebBrowser1.Height iImageNumber = iImageNumber + 1 SaveWebBrowserPicture "webpic" & iImageNumber Loop Caption = "Done" End If End Sub
From: Eduardo on 23 Sep 2009 01:08
I realized that it is not even necessary the form to be visible. Try this: Set the the project start up to Sub Main. Add a module with the procedure Public Sub Main, and there add the line: Load Form1 At the end of the form load procedure, add: Command1_Click At the end of the WebBrowser1_DocumentComplete event procedure, and after the line 'Caption = "Done"', add the line 'Unload Me' Comment the line Command1.SetFocus, otherwise it will raise an error. You'll see that there is nothing visual required to make it to work. So, it could be easily wrapped into a Dll as a class, or into an ocx as an invisible usercontrol. But, besides Shotgun, who could need this? It's interesting, but I need to work a little on my own program also... |