Solved

VB 6 - How make screenshot of webbrowser and save to jpg

Posted on 2011-09-22
24
1,881 Views
Last Modified: 2012-05-12
hello friends, i am have a vb6 application with a invisible webbrowser and i am need save a screenshot of this invisible webbrowser1 to .jpg or .bmp and save in c:\,.
please help me.
0
Comment
Question by:kidd12
  • 19
  • 4
24 Comments
 
LVL 3

Expert Comment

by:John_Arifin
ID: 36585964
0
 

Author Comment

by:kidd12
ID: 36586323
My friend i am need code for VB6, i am trying this and not function, this is vor vb.net.
I am need for vb6.
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36591110
Stand By....
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36591209
There are many examples of code to do this but they are all written in DELPHI.

I am not really a Delphi programmer, but I have come across some VB modules that have a lot of functionality for manipulating Bitpamps and seem to have similar subroutines to the ones written in Delphi, so I am attempting top write some VB6 modules using that code.

It may take a little while so please be patient...I will keep you posted...Please stand by

Cheers
Chris
(craisin)
0
 

Author Comment

by:kidd12
ID: 36592477
ok, i am waiting.
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36592593
It is about 1am here now (Australia) - I have to play in a bridge (card game) competition tomorrow [i.e. today :-) ] but I can work on it later after I get home.

It is quite involved but I think I may be able to do this using VB6 code. I need to find VB6 equivalent actions to those used in Delphi code I have found (not every one is possible). I think the use of CLASS modules will be required, and I have quite a few I can use, all associated with capturing screens and saving JPG images.

If we solve this, it will be a first,, since I cannot see elsewhere where anybody has done this using VB6.  Fingers crossed!  :-)

Be back in about 17 hours to concentrate on the work I have already prepared.

Cheers
Chris
0
 

Author Comment

by:kidd12
ID: 36593851
ok, i am waiting for solution of this problem. thanks
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599263
I have come up with thje following code, but it is having several problems, so I am testing ways to get it to work.

For the record I post the code below.

Stand by.......

(By the way, see my comments in your duplicated question on this matter).

Thanks
Chris
'PLace the following code inside a Form named Form1
Option Explicit
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long

Private Sub cmdCommand1_Click()
Dim cDib As New cDIBSection
Dim alTempPicture() As Long
Screen.MousePointer = vbHourglass
With WebBrowser1
   .Width = Me.ScaleX(800, vbPixels, Me.ScaleMode)
   .Height = Me.ScaleX(1100, vbPixels, Me.ScaleMode)
   .Navigate2 "http://www.ecbc.net.au"
   Do While Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
      DoEvents
   Loop
End With
With Form1.Picture1
  .Visible = False
  .BorderStyle = vbBSNone
  .AutoRedraw = True
  .Height = WebBrowser1.Height
  .Width = WebBrowser1.Width
End With
'copy Webbrowser image to picturebox
SaveWebBrowserToPictureBox Me, Me.WebBrowser1, Me.Picture1

''Create a cDIBSection from the PictureBox
bPutPictureInLongArray Me.Picture1, alTempPicture
SetBitmapBits Me.Picture1, (UBound(alTempPicture) + 1) * 4, alTempPicture(0)

cDib.CreateFromPicture Me.Picture1

''Copy the converted image to the Clipboard as an Image
cDib.CopyToClipboard False

''Copy the newly converted image back in the PictureBox
Picture1.Picture = Clipboard.GetData()

'Save the image to a file
SavePicture Picture1.Image, CKRTempFile("C:\Temp", ".jpg")

'clear the clipboard (to free memory)
Clipboard.Clear
Screen.MousePointer = vbDefault
MsgBox "Image Created"
End Sub

Private Sub Form_Unload(Cancel As Integer)
  End
End Sub

'====================================================================

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599264

'PLace the following code in a module
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 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

Public Sub SaveWebBrowserToPictureBox(Form1 As Form, WebBrowser1 As WebBrowser, Picture1 As PictureBox)
  Dim myWindow As Long
  Dim childWindow As Long
  Dim myClass As String
  Dim className As String * 256

  'Picture1.Width = WebBrowser1.Width
  'Picture1.Height = WebBrowser1.Height
  Picture1.Width = Screen.Width
  Picture1.Height = Screen.Height
  Picture1.Cls
  myClass = "Shell Embedding"
  childWindow = GetWindow(Form1.hwnd, GW_CHILD)
  Do
    GetClassName childWindow, className, 256
    If Left$(className, 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
  End If
  Picture1.Picture = Picture1.Image
End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599269

'Place the following code in another module
Option Explicit
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Public PicInfo As BITMAP

Public Function bPutPictureInLongArray(ByRef picPicture As PictureBox, _
                                       ByRef alPicture() As Long) As Boolean
  Dim BytesPerLine As Long
  Dim Size As Long
'
  GetObject picPicture.Image, Len(PicInfo), PicInfo
'  BytesPerLine = (PicInfo.bmWidth * 3 + 3) And &HFFFFFFFC
  Size = (BytesPerLine * PicInfo.bmHeight * 3)
  ReDim alPicture(0 To (Size / 4))
  GetBitmapBits picPicture.Image, Size, alPicture(0)
End Function

Open in new window

0
 
LVL 13

Accepted Solution

by:
Chris Raisin earned 500 total points
ID: 36599279

'Place the following vcode in a CLASS module named "CDIBSection"

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO, _
    ByVal un As Long, _
    lplpVoid As Long, _
    ByVal handle As Long, _
    ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

' Clipboard functions:
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8

' Handle to the current DIBSection:
Private m_hDIb As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_tBI As BITMAPINFO

Public Function CopyToClipboard( _
        Optional ByVal bAsDIB As Boolean = True _
    ) As Boolean
Dim lhDCDesktop As Long
Dim lHDC As Long
Dim lhBmpOld As Long
Dim hObj As Long
Dim lFmt As Long
Dim b() As Byte
Dim tBI As BITMAPINFO
Dim lPtr As Long
Dim hDibCopy As Long

    lhDCDesktop = GetDC(GetDesktopWindow())
    If (lhDCDesktop <> 0) Then
        lHDC = CreateCompatibleDC(lhDCDesktop)
        If (lHDC <> 0) Then
            If (bAsDIB) Then
               MsgBox "I don't know how to put a DIB on the clipboard! Copy as bitmap instead!!!"
                ' Create a duplicate DIBSection and copy
                ' to the clipboard:
                'LSet tBI = m_tBI
                'hDibCopy = CreateDIBSection( _
                '        lhDC, _
                '        m_tBI, _
                '        DIB_RGB_COLORS, _
                '        lPtr, _
                '        0, 0)
                'If (hDibCopy <> 0) Then
                '    lhBmpOld = SelectObject(lhDC, hObj)
                '    BitBlt lhDC, 0, 0, Width, Height, m_hDC, 0, 0, vbSrcCopy
                '    SelectObject lhDC, lhBmpOld
                '    lFmt = CF_DIB
                '
                '     '....
                                    
                'Else
                '    hObj = 0
                'End If
            Else
                ' Create a compatible bitmap and copy to
                ' the clipboard:
                hObj = CreateCompatibleBitmap(lhDCDesktop, Width, Height)
                If (hObj <> 0) Then
                    lhBmpOld = SelectObject(lHDC, hObj)
                    PaintPicture lHDC
                    SelectObject lHDC, lhBmpOld
                    lFmt = CF_BITMAP
                    ' Now set the clipboard to the bitmap:
                    If (OpenClipboard(0) <> 0) Then
                        EmptyClipboard
                        If (SetClipboardData(lFmt, hObj) <> 0) Then
                            CopyToClipboard = True
                        End If
                        CloseClipboard
                    End If
                End If
            End If
            DeleteDC lHDC
        End If
        DeleteDC lhDCDesktop
    End If
End Function

Public Function CreateDIB( _
        ByVal lHDC As Long, _
        ByVal lWidth As Long, _
        ByVal lHeight As Long, _
        ByRef hDib As Long _
    ) As Boolean
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    hDib = CreateDIBSection( _
            lHDC, _
            m_tBI, _
            DIB_RGB_COLORS, _
            m_lPtr, _
            0, 0)
    CreateDIB = (hDib <> 0)
End Function
Public Function CreateFromPicture( _
        ByRef picThis As StdPicture _
    )
Dim lHDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
    
    GetObjectAPI picThis.handle, Len(tBMP), tBMP
    If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
        lhDCDesktop = GetDC(GetDesktopWindow())
        If (lhDCDesktop <> 0) Then
            lHDC = CreateCompatibleDC(lhDCDesktop)
            DeleteDC lhDCDesktop
            If (lHDC <> 0) Then
                lhBmpOld = SelectObject(lHDC, picThis.handle)
                LoadPictureBlt lHDC
                SelectObject lHDC, lhBmpOld
                DeleteObject lHDC
            End If
        End If
    End If
End Function
Public Function Create( _
        ByVal lWidth As Long, _
        ByVal lHeight As Long _
    ) As Boolean
    ClearUp
    m_hDC = CreateCompatibleDC(0)
    If (m_hDC <> 0) Then
        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
            m_hBmpOld = SelectObject(m_hDC, m_hDIb)
            Create = True
        Else
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function
Public Property Get BytesPerScanLine() As Long
    ' Scans must align on dword boundaries:
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property

Public Property Get Width() As Long
    Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_tBI.bmiHeader.biHeight
End Property

Public Sub LoadPictureBlt( _
        ByVal lHDC As Long, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal lSrcWidth As Long = -1, _
        Optional ByVal lSrcHeight As Long = -1, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    )
    If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
    If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
    BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lHDC, lSrcLeft, lSrcTop, eRop
End Sub


Public Sub PaintPicture( _
        ByVal lHDC As Long, _
        Optional ByVal lDestLeft As Long = 0, _
        Optional ByVal lDestTop As Long = 0, _
        Optional ByVal lDestWidth As Long = -1, _
        Optional ByVal lDestHeight As Long = -1, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    )
    If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
    If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
    BitBlt lHDC, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, eRop
End Sub

Public Property Get hdc() As Long
    hdc = m_hDC
End Property
Public Property Get hDib() As Long
    hDib = m_hDIb
End Property
Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property
Public Sub RandomiseBits( _
        Optional ByVal bGray As Boolean = False _
    )
Dim bDib() As Byte
Dim x As Long, y As Long
Dim lC As Long
Dim tSA As SAFEARRAY2D
Dim xEnd As Long
    
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanLine()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

    ' random:
    Randomize Timer
    
    xEnd = (Width - 1) * 3
    If (bGray) Then
        For y = 0 To m_tBI.bmiHeader.biHeight - 1
            For x = 0 To xEnd Step 3
                lC = Rnd * 255
                bDib(x, y) = lC
                bDib(x + 1, y) = lC
                bDib(x + 2, y) = lC
            Next x
        Next y
    Else
        For x = 0 To xEnd Step 3
            For y = 0 To m_tBI.bmiHeader.biHeight - 1
                bDib(x, y) = 0
                bDib(x + 1, y) = Rnd * 255
                bDib(x + 2, y) = Rnd * 255
            Next y
        Next x
    End If
    
    ' Clear the temporary array descriptor
   ' This is necessary under NT4.
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    
End Sub

Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIb <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIb
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub

Public Function Resample( _
        ByVal lNewHeight As Long, _
        ByVal lNewWidth As Long _
    ) As cDIBSection
Dim cDib As cDIBSection
    Set cDib = New cDIBSection
    If cDib.Create(lNewWidth, lNewHeight) Then
        If (lNewWidth <> m_tBI.bmiHeader.biWidth) Or (lNewHeight <> m_tBI.bmiHeader.biHeight) Then
            ' Change in size, do resample:
            ResampleDib cDib
        Else
            ' No size change so just return a copy:
            cDib.LoadPictureBlt m_hDC
        End If
        Set Resample = cDib
    End If
End Function

Private Function ResampleDib(ByRef cDibTo As cDIBSection) As Boolean
Dim bDibFrom() As Byte
Dim bDibTo() As Byte

Dim tSAFrom As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D

    ' Get the bits in the from DIB section:
    With tSAFrom
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanLine()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4

    ' Get the bits in the to DIB section:
    With tSATo
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibTo.BytesPerScanLine()
        .pvData = cDibTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4

Dim xScale As Single
Dim yScale As Single

Dim x As Long, y As Long, xEnd As Long, xOut As Long

Dim fX As Single, fY As Single
Dim ifY As Long, ifX As Long
Dim dX As Single, dy As Single
Dim r As Long, r1 As Single, r2 As Single, r3 As Single, r4 As Single
Dim g As Long, g1 As Single, g2 As Single, g3 As Single, g4 As Single
Dim b As Long, b1 As Single, b2 As Single, b3 As Single, b4 As Single
Dim ir1 As Long, ig1 As Long, ib1 As Long
Dim ir2 As Long, ig2 As Long, ib2 As Long

    xScale = (Width - 1) / cDibTo.Width
    yScale = (Height - 1) / cDibTo.Height
    
    xEnd = cDibTo.Width - 1
        
    For y = 0 To cDibTo.Height - 1
        
        fY = y * yScale
        ifY = Int(fY)
        dy = fY - ifY
        
        For x = 0 To xEnd
            fX = x * xScale
            ifX = Int(fX)
            dX = fX - ifX
            
            ifX = ifX * 3
            ' Interpolate using the four nearest pixels in the source
            b1 = bDibFrom(ifX, ifY): g1 = bDibFrom(ifX + 1, ifY): r1 = bDibFrom(ifX + 2, ifY)
            b2 = bDibFrom(ifX + 3, ifY): g2 = bDibFrom(ifX + 4, ifY): r2 = bDibFrom(ifX + 5, ifY)
            b3 = bDibFrom(ifX, ifY + 1): g3 = bDibFrom(ifX + 1, ifY + 1): r3 = bDibFrom(ifX + 2, ifY + 1)
            b4 = bDibFrom(ifX + 3, ifY + 1): g4 = bDibFrom(ifX + 4, ifY + 1): r4 = bDibFrom(ifX + 5, ifY + 1)
            
            ' Interplate in x direction:
            ir1 = r1 * (1 - dy) + r3 * dy: ig1 = g1 * (1 - dy) + g3 * dy: ib1 = b1 * (1 - dy) + b3 * dy
            ir2 = r2 * (1 - dy) + r4 * dy: ig2 = g2 * (1 - dy) + g4 * dy: ib2 = b2 * (1 - dy) + b4 * dy
            ' Interpolate in y:
            r = ir1 * (1 - dX) + ir2 * dX: g = ig1 * (1 - dX) + ig2 * dX: b = ib1 * (1 - dX) + ib2 * dX
            
            ' Set output:
            If (r < 0) Then r = 0
            If (r > 255) Then r = 255
            If (g < 0) Then g = 0
            If (g > 255) Then g = 255
            If (b < 0) Then b = 0
            If (b > 255) Then
                b = 255
            End If
            xOut = x * 3
            bDibTo(xOut, y) = b
            bDibTo(xOut + 1, y) = g
            bDibTo(xOut + 2, y) = r
            
        Next x
        
    Next y

    ' Clear the temporary array descriptor
    ' This is necessary under NT4.
    CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
    CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4


End Function

Private Sub Class_Terminate()
    ClearUp
End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599362
By the way, on the form you must place inside a "Frame" the webbrowser WHICH MUST BE VISIBLE (WebBrowser1)  as well as a PictureBox called "{Picture1" WHICH ALSO MUST BE VISIBLE.

You then change the frame to NOT VISIBLE which hides the browser and picturebox from view.

You cannot save the contents of an invisible webbrowser, because once you make it invisible all its functionality is turned off internally by the VB6 engine. YTo avoid users seeing the browser, you use the trick of placing it in an invisible frame.

The contents of the browser is always as a bitmap and saving as a JPG is tricky. There has to be manipulation of the bits to confoirm with JPEG standards. This is supposed to work using methods stored in the class called  CDIBSection, but I am having problems, hopefully I can work around.


If you were using VB.Net there would be no worries since the webbrowser in VB.Net is much more powerful and open in architecture, allowing direct coding to save images etc.

One possibility is for me to write a DLL in VB.NET but I am not sure whether the DLL can then be used in VB6. I will resort to this if nothing else succeeds just to see if it is an option.

Could you please confirm two things:
     1. This solution must be in VB6 and use of VB.NET at the frontend is not a
        solution
      2. You want only JPEG.  If other image types are an option, which ones?
          BMP, GIF, ICO, PNG, SNAG?
0
Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599383
Oops....

PLease remove the line

    .Visible = False

from the code block referring to Picture1. (Line 18 in first listing of code)

Cheers
Chris

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599411
Some more code that is referenced. Place in seperate modules.
Option Explicit

Public Function CKRTempFile(Optional cDir As String, Optional cExt As String)
  Dim nRand As Integer
  Dim cRand As String

  If Len(Trim(cDir)) = 0 Then
    cDir = "c:\"

  End If
  If Dir(cDir + "\*.*", vbDirectory) = "" Then
    MkDir cDir
  End If
  If Len(Trim(cExt)) = 0 Then
    cExt = ".txt"

  End If

  Do While True
    nRand = CKRRandom(1000)
    cRand = CStr(nRand)

    If Right(cDir, 1) <> "\" Then
      cDir = cDir + "\"

    End If

    CKRTempFile = cDir + "Temp" + cRand + cExt

    If Not CKRFileExists(CKRTempFile) Then
      Exit Do

    End If

  Loop

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599417

Option Explicit

Public Function CKRRandom(nUpper As Integer, Optional nLower As Integer) As Integer
  Randomize
  CKRRandom = -1

  Do While CKRRandom < nLower
    CKRRandom = Int(nUpper * Rnd) + 1
  Loop

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36599420

Option Explicit

Public Function CKRFileExists(FileName) As Boolean
  Dim fs As Object
  Set fs = CreateObject("Scripting.FileSystemObject")
  CKRFileExists = fs.FileExists(FileName)

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600486
Success!

Forget all the earlier code (although a lot of it is used).

We no longer need the Class module or need to manipulate the data.

I think the code is self explanatory, but just ask if there is something you do not understand.

Basically what I have done is make sure the Webbrowser is visible TO THE  VB ENGINE when it loads its url. You cannot refresh a hidden WebBrowser. In order to hide the Browser from the user, I have locked the screen updates, made the browser visible, refreshed the browser with its url, copied the browser image (using its memory handle) to the clipboard, copied the clipboard contents to the PictureBox using the handle of the clipboard which is stored in the picturebox image pointer, then loaded the Picturebox picture calling the pointer in its "Image" property (I hope this makes sense).

Then it was just a matter of saving the Picturebox picture to a file and releasing the lock on the screen updates.


Now the lock on the screen updates would be a problem to you if you are using the program for other functionality (entering data, scrolling through listboxes etc) since it will seem to "freeze" for a short period.

I do not know if that is what you are doing, but if the program is simply running in the background from a list or URL's then it should not be a problem.

The code I have supplied gives you the methodolgy to load a webpage into a webbrowser, and save the contents of the first page (no scrolling....sorry) as a jpg image somewhere on your computer.

I think this is a first for VB6, since I could not find this solution anywhere on the internet (excepot by using VB.Net)

I hope this method will solve uyour problem.

Please let me know  :-)   (I need the points before the month runs out!)

Cheers
Chris


'Place his code inside a form named FORM1
Option Explicit
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Public Sub LockWindow()
  LockWindowUpdate GetDesktopWindow
End Sub

Public Sub UnLockWindow()
  'Releases the desktop lock
  LockWindowUpdate False
End Sub

Private Sub cmdCommand1_Click()

'Turn off any screen updates while the save is in progress
LockWindow

'This must be done to allopw the "Ready_State" to be evaluated
WebBrowser1.Visible = True

With WebBrowser1
   .Width = Me.ScaleX(800, vbPixels, Me.ScaleMode)
   .Height = Me.ScaleX(1100, vbPixels, Me.ScaleMode)
   .Navigate2 "http://www.ecbc.net.au"
   Do While Me.WebBrowser1.ReadyState <> READYSTATE_COMPLETE
      DoEvents
   Loop
End With
With Form1.Picture1
  .BorderStyle = vbBSNone
  .AutoRedraw = True
  .Height = Screen.Height
  .Width = Screen.Width
End With

'copy Webbrowser image to picturebox
SaveWebBrowserToPictureBox Me, Me.WebBrowser1, Me.Picture1

'Save the image to a file
SavePicture Picture1.Image, CKRTempFile("C:\Temp", ".jpg")

'return browser to previous state
WebBrowser1.Visible = False

'allow screen updates to resume now that webbrowser has been re-hidden
UnLockWindow
MsgBox "Image Created"
End Sub

Private Sub Form_Unload(Cancel As Integer)
  End
End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600491

'Place this code in its own module
Option Explicit

Public Function CKRFileExists(FileName) As Boolean
  Dim fs As Object
  Set fs = CreateObject("Scripting.FileSystemObject")
  CKRFileExists = fs.FileExists(FileName)

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600497

'Place this code in its own module
Option Explicit

Public Function CKRRandom(nUpper As Integer, Optional nLower As Integer) As Integer
  Randomize
  CKRRandom = -1

  Do While CKRRandom < nLower
    CKRRandom = Int(nUpper * Rnd) + 1
  Loop

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600503

'Place this code in its own module
Option Explicit

Public Function CKRTempFile(Optional cDir As String, Optional cExt As String)
  Dim nRand As Integer
  Dim cRand As String

  If Len(Trim(cDir)) = 0 Then
    cDir = "c:\"

  End If
  If Dir(cDir + "\*.*", vbDirectory) = "" Then
    MkDir cDir
  End If
  If Len(Trim(cExt)) = 0 Then
    cExt = ".txt"

  End If

  Do While True
    nRand = CKRRandom(1000)
    cRand = CStr(nRand)

    If Right(cDir, 1) <> "\" Then
      cDir = cDir + "\"

    End If

    CKRTempFile = cDir + "Temp" + cRand + cExt

    If Not CKRFileExists(CKRTempFile) Then
      Exit Do

    End If

  Loop

End Function

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600512

'Place this code in its own module called "SaveWebbrowserToPictureBox"

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 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

Public Sub SaveWebBrowserToPictureBox(Form1 As Form, WebBrowser1 As WebBrowser, _
                                      ByRef Picture1 As PictureBox)
  Dim myWindow As Long
  Dim childWindow As Long
  Dim myClass As String
  Dim className As String * 256

  WebBrowser1.Width = Screen.Width
  WebBrowser1.Height = Screen.Height
  Picture1.Width = Screen.Width
  Picture1.Height = Screen.Height
  Picture1.Cls
  myClass = "Shell Embedding"
  childWindow = GetWindow(Form1.hwnd, GW_CHILD)
  Do
    GetClassName childWindow, className, 256
    If Left$(className, 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
  End If
  Picture1.Picture = Picture1.Image
End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36600676
On the form, have a command button called "cmdButton1"

Place a picturebox called "Picture1" and a Webbrowser control called "WebBrowser1"

Set both the Webbrowser and picturebox properties for Visible to "False"

Run the program, and the form shoudl appear with just the button on it.

Click on the button and then shortly after a message "Image saved" will appear.

Go to the folder "C:\Temp" on your computer and a jpg file should be there with a "random" name (such as "Temp618.jpg"). When you click on that you will see a full screen image of the saved page from the browser.

Of course you will not use this exact code for what you are doing, but the module "SaveWebBrowserToPictureBox" is the critical module.

If you do not ant the screen to "lock" during the process, then we have a problem, beciuse the Webbrowser MUST be visible to enable the update of the browsers screen to finish before the code contunies, therie there may only be partial screen captures.

I have tried many things, but basically the Webbrowser is NOT FUNCTIONAL if it is invisible. The only way you can go to a webpage and save it is having the webbrowser visible. Locking the screen, making it visible, doing the processing, returning it to invisible and then unlocking the screen is the only way you can do it with an invisible Webbrowser.

Please let me know if that solves your dilemma...

Cheers
Chris
(craisin)
0
 

Author Closing Comment

by:kidd12
ID: 36601896
thankss
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 36698954
I notice that the accepted solution was comment 36599279, but I cannot believe that was the correct solution.

Please confirm that the comment 36600486 should be the correct answer.

I will then ask the moderator to adjust the records.

Many thanks
Chris
(craisin)
0

Featured Post

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now