VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsSnapWebSite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------
'Autor: Leandro Ascierto
'Web:   www.leandroascierto.com
'Date:  01/04/13
'Name:  ClsSnapWebSite
'---------------------------------------------
'GDI PLUS
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As Long, ByVal InterpolationMode As Long) As Long
Private Declare Function GdipSetPixelOffsetMode Lib "gdiplus" (ByVal graphics As Long, ByVal PixelOffsetMode As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal Callback As Long = 0, Optional ByVal CallbackData As Long = 0) As Long
Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
Private Declare Function GdipCreateHICONFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, hGraphics As Long) As Long
Private Declare Function GdipGetImageBounds Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mSrcRect As RECTF, ByRef mSrcUnit As Long) As Long
Private Declare Function GdipDrawImageRect Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, ByVal mX As Single, ByVal mY As Single, ByVal mWidth As Single, ByVal mHeight As Single) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Stride As Long, ByVal Format As Long, ByRef Scan0 As Any, ByRef BITMAP As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As Any, ByRef image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal mHbm As Long, ByVal mhPal As Long, ByRef mBitmap As Long) As Long
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
'KERNEL32
Private Declare Function SetProcessWorkingSetSize Lib "kernel32.dll" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function TlsGetValue Lib "kernel32.dll" (ByVal dwTlsIndex As Long) As Long
Private Declare Function TlsSetValue Lib "kernel32.dll" (ByVal dwTlsIndex As Long, ByVal lpTlsValue As Long) As Long
Private Declare Function TlsFree Lib "kernel32.dll" (ByVal dwTlsIndex As Long) As Long
Private Declare Function TlsAlloc Lib "kernel32.dll" () As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'USER32
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'GDI32
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'OLE32

Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, Id As GUID) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleDraw Lib "ole32.dll" (ByVal pUnknown As Object, ByVal dwAspect As Long, ByVal hdcDraw As Long, ByRef lprcBounds As RECT) As Long
'OLEPPRO32
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'URLMON
Private Declare Function CoInternetSetFeatureEnabled Lib "urlmon.dll" (ByVal FeatureEntry As Long, ByVal dwFlags As Long, ByVal fEnable As Long) As Long
'MSVBVM60
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long


Private Declare Function Rectangle Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Const NULL_BRUSH As Long = 5

Private Type IconHeader
    ihReserved          As Integer
    ihType              As Integer
    ihCount             As Integer
End Type

Private Type IconEntry
    ieWidth             As Byte
    ieHeight            As Byte
    ieColorCount        As Byte
    ieReserved          As Byte
    iePlanes            As Integer
    ieBitCount          As Integer
    ieBytesInRes        As Long
    ieImageOffset       As Long
End Type

Private Type RECTF
    Left    As Single
    Top     As Single
    Width   As Single
    Height  As Single
End Type

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

Private Type GUID
    Data1           As Long
    Data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type
  
Private Type EncoderParameter
    GUID            As GUID
    NumberOfValues  As Long
    Type            As Long
    Value           As Long
End Type
  
Private Type EncoderParameters
    Count           As Long
    Parameter(15)   As EncoderParameter
End Type
  
Private Type GDIPlusStartupInput
    GdiPlusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type

Private Type PictDesc
   Size     As Long
   Type     As Long
   hImage   As Long
   Data1    As Long
   Data2    As Long
End Type

Private Type DataIcon
    IE As IconEntry
    bData() As Byte
End Type

Private Const PixelFormat32bppARGB  As Long = &H26200A
Private Const UnitPixel             As Long = &H2&
  
Private Const ImageCodecBMP = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecGIF = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecTIF = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecPNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecICO = "{557CF407-1A04-11D3-9A73-0000F81EF32E}"
  
Private Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const EncoderCompression = "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
Private Const GUID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"    'IPicture

'IE7 and later
Private Const FEATURE_DISABLE_NAVIGATION_SOUNDS     As Long = &H15
Private Const SET_FEATURE_ON_PROCESS                As Long = &H2
 
Private Const DVASPECT_CONTENT      As Long = &H1
Private Const WM_MOUSEMOVE          As Long = &H200
Private Const IconVersion           As Long = &H30000
Private Const LR_LOADFROMFILE       As Long = &H10
Private Const IMAGE_ICON            As Long = 1
Private Const VT_BYREF              As Long = &H4000&
Private Const TLS_MINIMUM_AVAILABLE As Long = 64


Private Enum InterpolationMode
    InterpolationModeInvalid = &HFFFFFFFF
    InterpolationModeDefault = &H0
    InterpolationModeLowQuality = &H1
    InterpolationModeHighQuality = &H2
    InterpolationModeBilinear = &H3
    InterpolationModeBicubic = &H4
    InterpolationModeNearestNeighbor = &H5
    InterpolationModeHighQualityBilinear = &H6
    InterpolationModeHighQualityBicubic = &H7
End Enum

Private Enum PixelOffsetMode
    PixelOffsetModeInvalid = &HFFFFFFFF
    PixelOffsetModeDefault = &H0
    PixelOffsetModeHighSpeed = &H1
    PixelOffsetModeHighQuality = &H2
    PixelOffsetModeNone = &H3
    PixelOffsetModeHalf = &H4
End Enum

Public Enum enuThumbnailStyle
    eWEB_COMPLETE
    eADJUST_TO_THUMBNAIL
End Enum

Public Enum ImageCodec
    BMP
    PNG
    JPG
    GIF
    TIF
    ICO
End Enum

Public Enum FaviconSize
    SMALL_ICON = 16
    BIG_ICON = 32
End Enum

Public Enum CaptureState
    CS_Error = -1
    CS_Init = 0
    CS_NavigateComplete = 1
    CS_DocumentComplete = 2
    CS_DownloadFavicon = 3
    CS_Complete = 4
    CS_Stopped = 5
End Enum
    
Public Event CaptureComplete()

Private WithEvents WebBrowser1 As VBControlExtender
Attribute WebBrowser1.VB_VarHelpID = -1
Private m_FormParent        As Form
Private m_PicParent         As PictureBox
Private m_Picture           As StdPicture
Private ASM()               As Byte
Private ProcPtr             As Long
Private TimerID             As Long
Private m_hMod              As Long
Private m_MinWidth          As Long
Private m_MinHeight         As Long
Private m_ThumWidth         As Long
Private m_ThumHeight        As Long
Private m_ThumStyle         As enuThumbnailStyle
Private m_Title             As String
Private m_TimeDelay         As Long
Private m_DownloadFavicon   As Boolean
Private m_Complete          As Boolean
Private m_State             As CaptureState
Private m_ArrFavicon()      As Byte
Private m_UrlOriginal       As String
Private m_LocationURL       As String
Private m_DrawFrame         As Boolean
Private m_ArrShadow()       As Byte
Private m_Description       As String


'*No llamar, Privado ,No colocar ninguna funcion publica por ensima de esta
'Timer para prolongar la captura en espera de algunos objetos flash
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
     Call DestroyTimer
    
     If m_DownloadFavicon Then
         m_State = CS_DownloadFavicon
         DownloadFavicon
     End If
     
     m_LocationURL = WebBrowser1.object.LocationURL
     m_Description = GetDescription
     
     Call CaptureWeb(m_MinWidth, m_MinHeight)
    
     DisableSoundClick False
End Sub

'Estilo de la miniatura eWEB_COMPLETE o eADJUST_TO_THUMBNAIL
'eWEB_COMPLETE: captura la web completa y la reduce en proporcion al tamaño de la miniatura.
'eADJUST_TO_THUMBNAIL: captura la web completa, pero en la miniatura se ajusta al ancho y recorta el alto sobrante.
Public Property Let ThumbnailStyle(ByVal NewStyle As enuThumbnailStyle)
    m_ThumStyle = NewStyle
End Property

Public Property Get ThumbnailStyle() As enuThumbnailStyle
    ThumbnailStyle = m_ThumStyle
End Property

'Ancho de la miniatura, si el valor es 0, la captura sera del tamaño original del sitio web.
Public Property Let ThumbnailWidth(ByVal NewWidth As Long)
    m_ThumWidth = NewWidth
End Property

Public Property Get ThumbnailWidth() As Long
    ThumbnailWidth = m_ThumWidth
End Property

'Alto de la miniatura, si el valor es 0, la captura sera del tamaño original del sitio web.
Public Property Let ThumbnailHeight(ByVal NewHeight As Long)
    m_ThumHeight = NewHeight
End Property

Public Property Get ThumbnailHeight() As Long
    ThumbnailHeight = m_ThumHeight
End Property

'Ancho minimo para que se dibuje el sitio, por defecto 1024px.
'el proposito es emular el ancho de el navegador web o de nuestra pantalla.
Public Property Let MinWidth(ByVal NewWidth As Long)
    m_MinWidth = NewWidth
End Property

Public Property Get MinWidth() As Long
    MinWidth = m_MinWidth
End Property

'Alto minimo para que se dibuje el sitio, por defecto 768 px.
'el proposito es emular el alto de el navegador web o de nuestra pantalla.
Public Property Let MinHeight(ByVal NewHeight As Long)
    m_MinHeight = NewHeight
End Property

Public Property Get MinHeight() As Long
    MinHeight = m_MinHeight
End Property

'Tiempo extra de espera para dejar que se carguen algunos objetos, por ejemplo las peliculas flash.
Public Property Let TimeDelay(ByVal NewValue As Long)
    If NewValue < 1 Then NewValue = 1
    m_TimeDelay = NewValue
End Property

Public Property Get TimeDelay() As Long
    TimeDelay = m_TimeDelay
End Property

'Retorna el resultado de la captura en una image standar, si este is Nothing, fallo la captura.
Public Property Get Picture() As StdPicture
    Set Picture = m_Picture
End Property

'Dibuja un marco de color griz en la imagen
Public Property Let DrawFrame(ByVal NewValue As Boolean)
    m_DrawFrame = NewValue
End Property

Public Property Get DrawFrame() As Boolean
    DrawFrame = m_DrawFrame
End Property


'Titulo del sitio web.
Public Property Get Title() As String
    Title = m_Title
End Property

'Descripcion de la web (si es que tiene)
Public Property Get Description() As String
    Description = m_Description
End Property

'Formulario en el cual se creara el webbrowser, "es muy importante asignarlo antes de llamar a la función Snap"
'*para una mejor experiencia, antes de descargar la clase asignar parametro un Nothing, esto garantiza que no quede colgado, si la clase se encuentra en proceso.
Public Property Let Parent(ByVal oForm As Form)
    On Error Resume Next
    If Not m_FormParent Is Nothing Then
        m_FormParent.Controls.Remove "WebBrowser" & ObjPtr(Me)
        m_FormParent.Controls.Remove "Picture" & ObjPtr(Me)
        'I'm not sure about this, but is the only way to solve the memory increase produced by the webbrowser
        'No esto seguro de esto, pero es la unica forma que encontre de reducir el incremento automatico de la memoria producido por el webbrowser
        SetProcessWorkingSetSize GetCurrentProcess, -1, -1
    End If
    Set m_FormParent = oForm
    If Not m_FormParent Is Nothing Then
        Set m_PicParent = m_FormParent.Controls.Add("VB.PictureBox", "Picture" & ObjPtr(Me))
        Set WebBrowser1 = m_FormParent.Controls.Add("Shell.Explorer.2", "WebBrowser" & ObjPtr(Me), m_PicParent)
        WebBrowser1.Visible = True
    End If
End Property

Public Property Get Parent() As Form
    Set Parent = m_FormParent
End Property

'Retorna la url que se quiere capturar, tal cual se la paso en la funcion Snap
Public Property Get URL() As String
    URL = m_UrlOriginal
End Property

'Retorna la url en la que se pudo haber redireccionado(url de destino).
Public Property Get LocationURL() As String
    LocationURL = m_LocationURL
End Property

'funcion princial para iniciar la captura.
'sURL: url del sitio web que queremos capturar.
'DownloadFavicon: si necesitamos el icono de la web, por defecto = True
'Asynchronous: si queremos que la funcion esperar a que se termine la captura = false, de lo contrario, recibiremos el evento "CaptureComplete"
'*en experiencia es mejor trabajarlo como Asynchronous =True, ya que al finalizar la clase si no se trata correctamente podria queda la funcion colgada.
Public Function Snap(ByVal sURL As String, Optional DownloadFavicon As Boolean = True, Optional Asynchronous As Boolean = True) As Boolean

    Debug.Assert Not m_FormParent Is Nothing
    
    m_Description = vbNullString
    m_Title = vbNullString
    Set m_Picture = Nothing
    m_Complete = False
    m_State = CS_Init
    
    m_DownloadFavicon = DownloadFavicon
    m_UrlOriginal = sURL
    m_LocationURL = sURL
    
    'No funcionara con sitios ftp
    If (LCase(Left$(sURL, 6)) = "ftp://") Or (LCase(Left$(sURL, 4)) = "ftp.") Then
        m_State = CS_Error
        RaiseEvent CaptureComplete
        Exit Function
    End If
    
    DisableSoundClick True 'Quitamos el sonido Click
    WebBrowser1.object.Silent = True 'Ocultamos los mensages de error de javascript
    WebBrowser1.object.Navigate sURL

    If Asynchronous = False Then
        Do While m_Complete = False
            DoEvents
        Loop
    End If
    
    Snap = m_Picture Is Nothing

End Function

Private Function GetDescription() As String
    On Error Resume Next
    Dim vElement As Variant
    Dim i As Long
    
    Set vElement = WebBrowser1.object.Document.GetElementsByTagName("meta")
    For i = 0 To vElement.Length - 1
        If LCase(vElement(i).GetAttribute("name")) = "description" Then
            GetDescription = vElement(i).GetAttribute("content")
            Exit For
        End If
    Next
End Function

'Retorna un hIcon segun el tamaño indicado.
'*el programador es el encargado de destruirlo llamando a la api DestroyIcon
Public Function GetFavicon(ByVal IconSize As FaviconSize) As Long
    If IsArrayDim(VarPtrArray(m_ArrFavicon)) Then
        If m_ArrFavicon(2) = IMAGE_ICON Then
            GetFavicon = LoadIconFromStream(m_ArrFavicon, IconSize, IconSize)
        Else
            GetFavicon = CreateIconFromImageStream(m_ArrFavicon, IconSize, IconSize)
        End If
    End If
End Function

'Retorna un array de bits del icono original.
'* ojo este puede no ser un archivo icono, tambien puede ser una imagen PNG, GIF, etc.
Public Function GetFaviconStream() As Byte()
    GetFaviconStream = m_ArrFavicon
End Function

'Retorna si se descargo o si la web tiene favicon
Public Function IsFaviconPresent() As Boolean
    IsFaviconPresent = IsArrayDim(VarPtrArray(m_ArrFavicon))
End Function

'Retorna si el Favicon es un archivo.ico (tambien puede ser una imagen PNG, GIF, etc.)
Public Function IsFaviconFileICO() As Boolean
    If IsArrayDim(VarPtrArray(m_ArrFavicon)) Then
        IsFaviconFileICO = CBool(m_ArrFavicon(2) = IMAGE_ICON)
    End If
End Function

'Retorna el estado de la captura (en beta)
Public Property Get State() As CaptureState
    State = m_State
End Property

'Cancela la captura
'*para una mejor expeiencia llamar antes de descargar la clase
Public Sub Cancel()
    WebBrowser1.object.stop
    DestroyTimer
    Set m_Picture = Nothing
    m_Complete = True
    m_State = CS_Stopped
End Sub

'Guarda la captura en un archivo, si todo sale bien, retorna True
'DestPath: es la ruta de destino.
'ImageCodec: es el formato en que seguardara imagen (BMP, PNG, JPG, GIF, TIF, ICO)
Public Function SaveImageToFile(ByVal DestPath As String, Optional ByVal ImageCodec As ImageCodec = JPG) As Boolean
  
    On Error Resume Next
    Dim gdiSI As GDIPlusStartupInput, gToken As Long, hImage As Long
    Dim tEncoder  As GUID
    
    If m_Picture Is Nothing Then Exit Function

    Select Case ImageCodec
        'Case BMP: Call SavePicture(m_Picture, DestPath): SaveImageToFile = Err.Number = 0: Exit Function
        Case BMP: CLSIDFromString StrPtr(ImageCodecBMP), tEncoder
        Case JPG: CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
        Case PNG: CLSIDFromString StrPtr(ImageCodecPNG), tEncoder
        Case GIF: CLSIDFromString StrPtr(ImageCodecGIF), tEncoder
        Case TIF: CLSIDFromString StrPtr(ImageCodecTIF), tEncoder
        Case ICO
            SaveImageToFile = SaveAsIconFile(DestPath)
            Exit Function
        Case Else: Exit Function
    End Select
  
    gdiSI.GdiPlusVersion = &H1
    GdiplusStartup gToken, gdiSI
  
    If gToken Then
        If GdipCreateBitmapFromHBITMAP(m_Picture.Handle, m_Picture.hPal, hImage) = 0 Then
            If GdipSaveImageToFile(hImage, StrPtr(DestPath), tEncoder, ByVal 0&) = 0 Then
                SaveImageToFile = True
            End If
            GdipDisposeImage hImage
        End If
        GdiplusShutdown gToken
    End If
  
End Function

'Guarda la captura en un array de bytes, si todo sale bien, retorna True
'OutStream: variable array de bytes
'ImageCodec: es el formato en que seguardara imagen (BMP, PNG, JPG, GIF, TIF, ICO)
Public Function SaveImageToStream(ByRef OutStream() As Byte, Optional ByVal ImageCodec As ImageCodec = JPG) As Boolean
    Dim gdiSI As GDIPlusStartupInput, gToken As Long, hImage As Long
    Dim IStream    As IUnknown
    Dim tEncoder    As GUID

    Erase OutStream
    
    If m_Picture Is Nothing Then Exit Function
    
    Select Case ImageCodec
        Case BMP: CLSIDFromString StrPtr(ImageCodecBMP), tEncoder
        Case JPG: CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
        Case PNG: CLSIDFromString StrPtr(ImageCodecPNG), tEncoder
        Case GIF: CLSIDFromString StrPtr(ImageCodecGIF), tEncoder
        Case TIF: CLSIDFromString StrPtr(ImageCodecTIF), tEncoder
        Case ICO
            SaveImageToStream = SaveAsIconStream(OutStream)
            Exit Function
        Case Else: Exit Function
    End Select
    
    Set IStream = CreateStream(OutStream)
    
    If Not IStream Is Nothing Then
        gdiSI.GdiPlusVersion = 1&
        GdiplusStartup gToken, gdiSI
        
        If gToken Then
            If GdipCreateBitmapFromHBITMAP(m_Picture.Handle, m_Picture.hPal, hImage) = 0 Then
                 If GdipSaveImageToStream(hImage, IStream, tEncoder, ByVal 0&) = 0& Then
                    SaveImageToStream = ArrayFromStream(IStream, OutStream())
                End If
                GdipDisposeImage hImage
            End If
            GdiplusShutdown gToken
        End If
    End If
End Function

'---------------------------------------------------------------------------------------------
'Evento del Webbrowser (VBControlExtender)
Private Sub WebBrowser1_ObjectEvent(Info As EventInfo)

    If m_Complete Then Exit Sub

    Select Case Info.Name
    
        Case "NavigateComplete2"
            If m_State = CS_Init Then
                m_State = CS_NavigateComplete
                'Inhabilita, que se disparen los cuadros de dialogs Alert, confirm (msgbox), prompt(inputbox)
                With WebBrowser1.object.Document.parentWindow
                    .execScript "window.alert = function () { };", "JScript"
                    .execScript "window.confirm = function () { };", "JScript"
                    .execScript "window.prompt = function () { };", "JScript"
                End With
            End If
            
        Case "DocumentComplete"
            If m_State <> CS_NavigateComplete Then Exit Sub
            
            If WebBrowser1.object.Document.ReadyState = "complete" Then
                CreateTimer m_TimeDelay
                m_State = CS_DocumentComplete
            End If
            
        Case "TitleChange"
            m_Title = Info.EventParameters(0)
            
        Case "NewWindow2"
            'Cancela que se abra otra ventana(PopUp).
            Info.EventParameters(1) = True
            
        Case "NavigateError"
            'Segun que tipo de error.
            If Info.EventParameters(3) < 0 Then
                If m_State <> CS_Error Then
                    m_State = CS_Error
                    RaiseEvent CaptureComplete
                    m_Complete = True
                End If
            End If
    End Select

End Sub
'---------------------------------------------------------------
'PRIVATE FUNCTIONS
'---------------------------------------------------------------

Private Sub CreateArrayShadowImage()
    
    Dim i As Long
    Dim j As Long
                           
    Const sHexShadow = "89504E470D0A1A0A0000000D494844520000000F0000000F08060000003BD6954A0000002C744558744372656174696F6E2054696D65006D69E92031302061627220323031332032303A30373A3235202D303330304C76623E0000000774494D4507DD040A171B306ECFAD36000000097048597300001EC200001EC2016ED0753E0000000467414D410000B18F0BFC6105000000B14944415478DAAD924B0EC2300C449BB82058F4045C840DF7BF0FDF166883074D906B52012A969E92D633B695A4AA6644F831973E0982C31A2D6F667C474548E43F8807A527D8A75030D6CAD290CD57C39D055E01E3426926CE60A76C98872E462710762B050C6BE62577B3630B45A58076C53C74C19B7D413F9598FCC89CEF709830DFCC493FF5B533F7146D3962EE86D3DD2B17532449616CAC1D8558CFCA51392827A5658179F7FCB717660B7CF5B61FCFD23A9B05E3F0F50000000049454E44AE426082"
               
    ReDim m_ArrShadow((Len(sHexShadow) / 2) - 1)
    
    For i = 0 To Len(sHexShadow) - 1 Step 2
        m_ArrShadow(j) = CLng("&H" & Mid$(sHexShadow, i + 1, 2))
        j = j + 1
    Next
    
    'ArrShadow = LoadResData("SHADOW", "CUSTOM")
End Sub

'Guarda la captura como un archivo icono con 4 dimenciones (256,48,32,16)
Private Function SaveAsIconFile(ByVal DestPath As String) As Boolean
    On Error GoTo ErrHandler
    Dim FFile As Integer
    Dim OutStream() As Byte
    
    If SaveAsIconStream(OutStream) Then
        FFile = FreeFile
        Open DestPath For Binary As FFile
            Put FFile, , OutStream
        Close FFile
        SaveAsIconFile = True
    End If
    Exit Function
ErrHandler:

End Function

'Guarda la captura como icono en un array de bytes con 4 dimenciones (256,48,32,16)
Private Function SaveAsIconStream(ByRef OutStream() As Byte) As Boolean
    On Error GoTo ErrHandler
    
    Dim hImgShadow As Long, hImgCanvas As Long, hGraphics As Long, hImage As Long
    Dim gdiSI           As GDIPlusStartupInput
    Dim TR              As RECTF
    Dim IStream         As IUnknown
    Dim gToken          As Long
    Dim tEncoder        As GUID
    Dim ArrIconPNG()    As Byte
    Dim lPos            As Long
    Dim DI()            As DataIcon
    Dim lSize           As Long
    Dim tIH             As IconHeader
    Dim tIE             As IconEntry
    Dim ImageOffset     As Long
    Dim i               As Long
    Dim ArrIconData()   As Byte


    lPos = -1
    gdiSI.GdiPlusVersion = 1&
    If GdiplusStartup(gToken, gdiSI) = 0 Then
    
        If GdipCreateBitmapFromScan0(256&, 256&, 0&, PixelFormat32bppARGB, ByVal 0&, hImgCanvas) = 0 Then
                        
            If GdipGetImageGraphicsContext(hImgCanvas, hGraphics) = 0 Then

                If GdipCreateBitmapFromHBITMAP(m_Picture.Handle, 0, hImage) = 0 Then
                    Call GdipGetImageBounds(hImage, TR, UnitPixel)
                    Call GdipSetInterpolationMode(hGraphics, InterpolationModeHighQualityBicubic)
                    Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHighQuality)
                    GdipDrawImageRectRectI hGraphics, hImage, 5, 5, 256 - 10, 256 - 10, 0, 0, TR.Width, TR.Height, &H2, 0&, 0&, 0&
                    GdipDisposeImage hImage
                    
                    
                    If Not IsArrayDim(VarPtrArray(m_ArrShadow)) Then CreateArrayShadowImage
                    
                    Set IStream = CreateStream(m_ArrShadow)
   
                    If Not IStream Is Nothing Then
                        If GdipLoadImageFromStream(IStream, hImgShadow) = 0 Then
                            RenderStretchPlus hGraphics, 0, 0, 256, 256, hImgShadow, 0, 0, 15, 15, 5
                            GdipDisposeImage hImgShadow
                        End If
                    End If
                    
                    Call GdipDeleteGraphics(hGraphics)
                    
                    '----------Icon PNG
                    Set IStream = CreateStream(ArrIconPNG)
                    
                    If Not IStream Is Nothing Then
                    
                        CLSIDFromString StrPtr(ImageCodecPNG), tEncoder
                           
                        If GdipSaveImageToStream(hImgCanvas, IStream, tEncoder, ByVal 0&) = 0& Then
                            Call ArrayFromStream(IStream, ArrIconPNG())
                            
                            lPos = lPos + 1
                            ReDim DI(lPos)
                            
                            DI(lPos).bData = ArrIconPNG
                            With DI(lPos).IE
                               .ieBitCount = 32
                               .ieBytesInRes = UBound(DI(lPos).bData) + 1
                               .ieHeight = 0
                               .ieWidth = 0
                               .iePlanes = 1
                            End With
                            
                        End If

                    End If
                    
                    '---------- Icon 48x48
                    tIE.ieWidth = 48: tIE.ieHeight = 48
                    If ImageToIconEntry(hImgCanvas, tIE, ArrIconData) Then
                        lPos = lPos + 1
                        ReDim Preserve DI(lPos)
                        DI(lPos).IE = tIE
                        DI(lPos).bData = ArrIconData
                    End If


                    
                End If
                
            End If
            GdipDisposeImage hImgCanvas
        End If

        If Me.IsFaviconPresent Then
            '---------Icon 32x32
            tIE.ieWidth = 32: tIE.ieHeight = 32
            If IconEntryFromFavicon(tIE, ArrIconData) Then
                lPos = lPos + 1
                ReDim Preserve DI(lPos)
                DI(lPos).IE = tIE
                DI(lPos).bData = ArrIconData
            End If
            '----------Icon 16x16
            tIE.ieWidth = 16: tIE.ieHeight = 16
            If IconEntryFromFavicon(tIE, ArrIconData) Then
                lPos = lPos + 1
                ReDim Preserve DI(lPos)
                DI(lPos).IE = tIE
                DI(lPos).bData = ArrIconData
            End If
            
        End If
    
        GdiplusShutdown gToken: gToken = 0
    End If
    
    If lPos = -1 Then Exit Function
    
    tIH.ihType = IMAGE_ICON
    tIH.ihCount = lPos + 1
    
    ReDim OutStream(6 + (tIH.ihCount * 16) - 1)
    
    CopyMemory OutStream(0), tIH, 6

    For i = 0 To UBound(DI)
        DI(i).IE.ieImageOffset = 6 + (tIH.ihCount * 16) + ImageOffset
        CopyMemory OutStream(6 + (i * 16)), DI(i).IE, 16
        ImageOffset = ImageOffset + UBound(DI(i).bData) + 1
    Next
    
    ReDim Preserve OutStream(UBound(OutStream) + ImageOffset)
    
    For i = 0 To UBound(DI)
        CopyMemory OutStream(DI(i).IE.ieImageOffset), DI(i).bData(0), UBound(DI(i).bData) + 1
    Next
    SaveAsIconStream = True
    Exit Function
    
ErrHandler:
    If gToken Then GdiplusShutdown gToken
End Function

'obtiene las medidas del favicon segun lo indicado dentro de tIconEntry, si no existe lo crea con gdi+
'si la funcion tiene exito completa los parametros con la entrada del icono y devuelve true
Private Function IconEntryFromFavicon(tIconEntry As IconEntry, bImgData() As Byte) As Boolean
    Dim tIH As IconHeader
    Dim tIE As IconEntry
    Dim hImage As Long
    Dim IStream As IUnknown
    Dim i As Long
    
  
    
    If Me.IsFaviconFileICO Then
        CopyMemory tIH, m_ArrFavicon(0), Len(tIH)
        
        If tIH.ihCount > 0 Then
           
            For i = 1 To tIH.ihCount
                CopyMemory tIE, m_ArrFavicon(Len(tIH) + ((i - 1) * 16)), 16 '16 = len(IconEntry)
                If (tIE.ieWidth = tIconEntry.ieWidth) And (tIE.ieHeight = tIconEntry.ieHeight) Then
                    tIconEntry = tIE
                    ReDim bImgData(tIE.ieBytesInRes - 1)
                    CopyMemory bImgData(0), m_ArrFavicon(tIE.ieImageOffset), tIE.ieBytesInRes
                    IconEntryFromFavicon = True
                    Exit Function
                End If
            Next
        
        End If
    End If
    
    Set IStream = CreateStream(m_ArrFavicon)
    
    If Not IStream Is Nothing Then
        If GdipLoadImageFromStream(IStream, hImage) = 0 Then
            IconEntryFromFavicon = ImageToIconEntry(hImage, tIconEntry, bImgData)
            GdipDisposeImage hImage
        End If
    End If
        
End Function

'crea la entrada de un icono a partir de un hImage de GDI+
'si la funcion tiene exito completa los parametros con la entrada del icono y devuelve true
'Nota: el icono siempre va a ser de 32 bits, y su mascara solo es un array bacio
Private Function ImageToIconEntry(hImage As Long, tIE As IconEntry, bImgData() As Byte) As Boolean
    Dim hImgCanvas As Long, hGraphics As Long
    Dim ArrColor()  As Byte
    Dim lSize       As Long
    Dim tEncoder    As GUID
    Dim TR          As RECTF
    Dim IStream    As IUnknown

     CLSIDFromString StrPtr(ImageCodecBMP), tEncoder
     
     If GdipCreateBitmapFromScan0(tIE.ieWidth, tIE.ieHeight, 0&, PixelFormat32bppARGB, ByVal 0&, hImgCanvas) = 0 Then
        If GdipGetImageGraphicsContext(hImgCanvas, hGraphics) = 0 Then
    
            Call GdipGetImageBounds(hImage, TR, UnitPixel)
            Call GdipSetInterpolationMode(hGraphics, InterpolationModeHighQualityBicubic)
            Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHighQuality)
            GdipDrawImageRectRectI hGraphics, hImage, 0, 0, tIE.ieWidth, tIE.ieHeight, 0, 0, TR.Width, TR.Height, &H2, 0&, 0&, 0&
            Call GdipDeleteGraphics(hGraphics)
            
            Set IStream = CreateStream(ArrColor)
                        
            If Not IStream Is Nothing Then
    
                If GdipSaveImageToStream(hImgCanvas, IStream, tEncoder, ByVal 0&) = 0& Then
                    Call ArrayFromStream(IStream, ArrColor())
                        
                    lSize = UBound(ArrColor) - 14 '14 = len(BITMAPFILEHEADER)
                    ReDim bImgData(lSize + AlignScan(tIE.ieWidth, 32)) '+ Size Mask (Empty)
                    CopyMemory bImgData(0), ArrColor(14), lSize 'Remove BITMAPFILEHEADER
                    CopyMemory bImgData(8), CLng(tIE.ieHeight * 2), 4 'BITMAPINFOHEADER.biHeight * 2
                    tIE.ieBytesInRes = UBound(bImgData) + 1
                    ImageToIconEntry = True
                End If
                
            End If
    
        End If
        GdipDisposeImage hImgCanvas
     End If

End Function

Private Function AlignScan(ByVal inWidth As Long, ByVal inDepth As Integer) As Long
    AlignScan = (((inWidth * inDepth) + &H1F) And Not &H1F&) \ &H8&
End Function

Private Function CreateTimer(ByVal MilliSeconds As Long) As Long
   Dim ret As Long
   
   If TimerID = 0 Then
      ret = SetTimer(0&, 0&, MilliSeconds, ProcPtr)
      If ret <> 0 Then
         TimerID = ret
         CreateTimer = ret
      End If
   Else
      CreateTimer = TimerID
   End If

End Function

Private Function DestroyTimer() As Long
   Dim ret As Long
   
   If TimerID <> 0 Then
      ret = KillTimer(0&, TimerID)
      If ret <> 0 Then
         TimerID = 0
      End If
   End If
End Function

'By activevb.de
Private Function GetProcPtr(ClassPtr As Long, ProcNumber As Long) As Long
   Dim ptrTemp As Long
   Dim ptrProc As Long
   
   CopyMemory ptrTemp, ByVal ClassPtr, 4
   CopyMemory ptrProc, ByVal ptrTemp + &H1C + (4 * ProcNumber), 4
   GetProcPtr = ptrProc
End Function

'By activevb.de 'para el timer
Private Function CreateASMContainer(ClassPtr As Long, ProcNumber As Long) As Long
   Dim ProcPtr As Long
   Dim l As Long
   Dim W As Long
   
   Const asmMain               As String = "558BEC50FF7514FF7510FF750CFF75086855555555B866666666FFD0C9C21000"
   
   ProcPtr = GetProcPtr(ClassPtr, ProcNumber)
   l = Len(asmMain) \ 2 - 1
   
   ReDim ASM(0 To l)
   
   For W = 0 To l
     ASM(W) = "&H" & Mid$(asmMain, W * 2 + 1, 2)
   Next
   
   CopyMemory ASM(17), ClassPtr, 4
   CopyMemory ASM(22), ProcPtr, 4
   
   CreateASMContainer = VarPtr(ASM(0))
End Function

Private Sub Class_Initialize()
    m_hMod = LoadLibrary("explorer.exe") 'esto es para que se muestren los temas de windows dentro del webbrowser.
    ProcPtr = CreateASMContainer(ObjPtr(Me), 0) 'para el timer
    m_TimeDelay = 1
    m_MinWidth = 1024
    m_MinHeight = 768
End Sub

Private Sub Class_Terminate()
    
    On Error Resume Next
    DestroyTimer
    
    If Not m_FormParent Is Nothing Then
        m_FormParent.Controls.Remove "WebBrowser" & ObjPtr(Me)
        m_FormParent.Controls.Remove "Picture" & ObjPtr(Me)
    End If
    
    Set WebBrowser1 = Nothing
    Set m_PicParent = Nothing
    Set m_FormParent = Nothing
    Set m_Picture = Nothing
    
    If m_hMod <> 0 Then FreeLibrary m_hMod
    'I'm not sure about this, but is the only way to solve the memory increase produced by the webbrowser
    SetProcessWorkingSetSize GetCurrentProcess, -1, -1
End Sub

'Deshabilita el sonido click del webbrowser
Private Sub DisableSoundClick(ByVal bEnabled As Boolean)
    On Error Resume Next
    Dim lRet As Long
    If bEnabled Then
        lRet = ReadValue(&HCAFECAFE)
        If lRet = 0 Then CoInternetSetFeatureEnabled FEATURE_DISABLE_NAVIGATION_SOUNDS, SET_FEATURE_ON_PROCESS, True
        WriteValue &HCAFECAFE, lRet + 1
    Else
        lRet = ReadValue(&HCAFECAFE)
        If lRet = 1 Then CoInternetSetFeatureEnabled FEATURE_DISABLE_NAVIGATION_SOUNDS, SET_FEATURE_ON_PROCESS, False
        WriteValue &HCAFECAFE, lRet - 1
    End If
End Sub


'Funcion privada para renderiazar el webbrowser y pasarlo a una imagen
'opcion MinWidth 800 MinHeight 600
Private Function CaptureWeb(Optional ByVal MinWidth As Long = 1024, Optional ByVal MinHeight As Long = 768) As Boolean
    On Error Resume Next
    
    Dim lngEmbeddingHwnd As Long, lngDocViewHwnd As Long, lngExplorerServer As Long
    Dim oDoc As Object, oElement As Object
    Dim lngSiteHeight As Long, lngSiteWidth As Long
    Dim tRECT As RECT
    Dim hdc As Long, hDCMemory As Long
    Dim hBmp As Long, hBmpPrev As Long, ThumBmp As Long
    Dim lWidth As Long, lHeight As Long
    Dim ThumWidth As Long, ThumHeight As Long
    
    If (WebBrowser1.object.Document Is Nothing) Then Exit Function
        
    Set oDoc = WebBrowser1.object.Document
    Set oElement = oDoc.documentElement

    lngEmbeddingHwnd = FindWindowEx(m_PicParent.hwnd, 0&, "Shell Embedding", vbNullString)
        
    If lngEmbeddingHwnd = 0& Then Exit Function
    
    lngDocViewHwnd = FindWindowEx(lngEmbeddingHwnd, 0&, "Shell DocObject View", vbNullString)
    
    If lngDocViewHwnd = 0& Then Exit Function

    lngExplorerServer = FindWindowEx(lngDocViewHwnd, 0&, "Internet Explorer_Server", vbNullString)
        
    lWidth = MinWidth + 4
    lHeight = MinHeight + 4

    'Achica la ventana pra poder recalcular el tamaño
    If MoveWindow(lngDocViewHwnd, 0, 0, lWidth, lHeight, 0) = 0& Then Exit Function
    
    DoEvents
    
    If oElement.ClientWidth = 0 And oElement.ClientHeight = 0 Then
        lngSiteWidth = oDoc.body.scrollWidth + 4
        lngSiteHeight = oDoc.body.scrollHeight + 4
        Call MoveWindow(lngDocViewHwnd, 0, 0, lngSiteWidth, lngSiteHeight, 0)
        lngSiteWidth = oDoc.body.scrollWidth + 4
        lngSiteHeight = oDoc.body.scrollHeight + 4
        'Debug.Print 1
    Else
        If (oElement.ClientWidth = oElement.scrollWidth) And (oElement.ClientHeight = oElement.scrollHeight) Then
            lngSiteWidth = MinWidth + 4
            lngSiteHeight = MinHeight + 4
            'Debug.Print 2
        Else
            lngSiteWidth = oElement.scrollWidth + 4
            lngSiteHeight = oElement.scrollHeight + 4
            'Debug.Print 3
        End If
        
    End If
    
    oDoc.body.Scroll = "no" 'Quita el scroll de la pagina
    oDoc.body.Style.overflow = "hidden" 'Oculta el overflow
    'el SendMessage es producir un refresco al pasar el mouse en la pantalla, ya que algunas web sin esto no se reacomodan.
    SendMessage lngExplorerServer, WM_MOUSEMOVE, 0, ByVal 0

    If lngSiteWidth > MinWidth Then lWidth = lngSiteWidth
    If lngSiteHeight > MinHeight Then lHeight = lngSiteHeight

    If m_ThumStyle = eADJUST_TO_THUMBNAIL Then
        If lWidth > lHeight Then
            lHeight = m_ThumHeight * (lWidth / m_ThumWidth)
        End If
    End If

    
    If MoveWindow(lngDocViewHwnd, 0, 0, lWidth, lHeight, 1) = 0 Then Exit Function
     
    DoEvents
    
    hdc = GetDC(0)
    hDCMemory = CreateCompatibleDC(hdc)
    hBmp = CreateCompatibleBitmap(hdc, lWidth, lHeight)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    ReleaseDC 0&, hdc
    
    tRECT.Right = lWidth
    tRECT.Bottom = lHeight
    
    'Api princial para capturar el webbrowser
    If OleDraw(WebBrowser1.object.Document, DVASPECT_CONTENT, hDCMemory, tRECT) = 0& Then

        If (m_ThumWidth = 0) And (m_ThumHeight = 0) Then
            ThumWidth = lWidth - 4
            ThumHeight = lHeight - 4
        Else
            ThumWidth = m_ThumWidth
            ThumHeight = m_ThumHeight
        End If

        ThumBmp = CreateThumbnail(ThumWidth, ThumHeight, hDCMemory, lWidth, lHeight)

        Set m_Picture = CreatePicture(ThumBmp, vbPicTypeBitmap)
     
    End If

    Call DeleteObject(SelectObject(hDCMemory, hBmpPrev))
    Call DeleteDC(hDCMemory)
    
    
    m_Complete = True
    WebBrowser1.object.Navigate "about:blank" 'Esto es porque si hay un video o audio no se reproduzca
    
    'I'm not sure about this, but is the only way to solve the memory increase produced by the webbrowser
    SetProcessWorkingSetSize GetCurrentProcess, -1, -1
    
    m_State = CS_Complete
    
    Set oElement = Nothing
    Set oDoc = Nothing
    
    
    RaiseEvent CaptureComplete
    
End Function

'Crea la miniatura
Private Function CreateThumbnail(ByVal DestWidth As Long, ByVal DestHeight As Long, ByVal SrcHdc As Long, SrcWidth As Long, ByVal SrdHeight As Long) As Long
    Dim hdc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim HScale As Double, VScale As Double
    Dim MyScale As Double

    If (m_ThumWidth <> 0) And (m_ThumHeight <> 0) Then
        If m_ThumStyle = eWEB_COMPLETE Then
            HScale = DestWidth / SrcWidth
            VScale = DestHeight / SrdHeight
            MyScale = IIf(VScale >= HScale, HScale, VScale)
            DestWidth = SrcWidth * MyScale
            DestHeight = SrdHeight * MyScale
        Else
            SrdHeight = DestHeight * (SrcWidth / DestWidth)
        End If
    End If
    
    hdc = GetDC(0)
    
    hDCMemory = CreateCompatibleDC(hdc)

    hBmp = CreateCompatibleBitmap(hdc, DestWidth, DestHeight)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    ReleaseDC 0&, hdc
    
    SetStretchBltMode hDCMemory, vbPaletteModeNone

    StretchBlt hDCMemory, 0, 0, DestWidth, DestHeight, SrcHdc, 2, 2, SrcWidth - 4, SrdHeight - 4, vbSrcCopy
    
    If m_DrawFrame Then DrawRectangle hDCMemory, 0, 0, DestWidth, DestHeight, &HCCCCCC
    
    Call SelectObject(hDCMemory, hBmpPrev)
    Call DeleteDC(hDCMemory)
    
    CreateThumbnail = hBmp
    
    
End Function

Private Sub DrawRectangle(hdc As Long, X As Long, Y As Long, Width As Long, Height As Long, oColor As OLE_COLOR)
    Dim hPen As Long, OldhPen As Long
    Dim OldBrush As Long
    hPen = CreatePen(0, 1, oColor)
    OldhPen = SelectObject(hdc, hPen)
    OldBrush = SelectObject(hdc, GetStockObject(NULL_BRUSH))
    Rectangle hdc, 0, 0, Width, Height
    DeleteObject SelectObject(hdc, Height)
    Call SelectObject(hdc, OldBrush)
End Sub

Private Function CreatePicture(ByVal hImage As Long, Optional ByVal PicType As PictureTypeConstants = vbPicTypeBitmap, Optional Data1 As Long = 0, Optional Data2 As Long = 0) As IPicture
   
   Dim pic As PictDesc
   Dim IPic As IPicture
   Dim IID_IDispatch As GUID
   

   ' Fill PictDesc struct with necessary parts
   With pic
      .Size = Len(pic)           ' Length of structure
      .Type = PicType            ' Type of Picture
      .hImage = hImage           ' Handle to image
      .Data1 = Data1
      .Data2 = Data2
   End With
   
   ' Fill in with IDispatch Interface ID
   CLSIDFromString StrPtr(GUID_IPicture), IID_IDispatch
   

   ' Create and return Picture object
   If OleCreatePictureIndirect(pic, IID_IDispatch, False, IPic) = 0& Then
      Set CreatePicture = IPic
   End If
End Function

'Sub privada para descargar el Favicon de la web.
Private Sub DownloadFavicon()
    On Error GoTo Fail:
    
    Dim sUrlFavicon As String
    Dim m_Inet As Object
    Dim vResults As Variant
    Dim lPos As Long
    Dim sCode As String
        
    Erase m_ArrFavicon

    sUrlFavicon = GetURLFavicon()

    If LenB(sUrlFavicon) > 0 Then
        If LCase(Left(sUrlFavicon, 5)) = "data:" Then
            lPos = InStr(sUrlFavicon, ",")
            If lPos <> 0 Then
                sCode = Mid$(sUrlFavicon, lPos + 1)
                m_ArrFavicon = Base64Decode(sCode)
            End If
        Else
            Set m_Inet = CreateObject("WinHttp.WinHttpRequest.5.1")
            m_Inet.Option(0) = "vb6_FaviconRequest"
            m_Inet.Open "GET", sUrlFavicon, False
            m_Inet.send
            
            m_Inet.WaitForResponse
            
            If m_Inet.Status <> 200 Then GoTo Fail
        
            If LenB(m_Inet.responsetext) = 0 Then GoTo Fail
            vResults = m_Inet.ResponseBody
            MoveArrayToVariant vResults, m_ArrFavicon(), False
            Set m_Inet = Nothing
        End If
    End If

    Exit Sub
Fail:
    
End Sub

'Funcion privada pra obtener la url del favicon
Private Function GetURLFavicon() As String
    Dim vElement As Variant
    Dim sLink As String
    Dim i As Long
    
    Set vElement = WebBrowser1.object.Document.GetElementsByTagName("link")
    For i = 0 To vElement.Length - 1
        If UCase(vElement(i).GetAttribute("rel")) = "SHORTCUT ICON" Then
            sLink = vElement(i).GetAttribute("href")
        End If
    Next
    
    If Len(sLink) = 0 Then
        For i = 0 To vElement.Length - 1
            If UCase(vElement(i).GetAttribute("rel")) = "ICON" Then
                sLink = vElement(i).GetAttribute("href")
            End If
        Next
    End If
    
    GetURLFavicon = ResolveFaviconURL(WebBrowser1.object.LocationURL, sLink)
    
End Function

Private Function ResolveFaviconURL(ByVal sOriginal As String, ByVal sLink As String) As String

    Dim sServer As String, sPath As String, sProtocol As String
    Dim lPos As Long
    
    lPos = InStr(sOriginal, ".")
    lPos = InStr(lPos, sOriginal, "/")

    If lPos Then
        sServer = Left$(sOriginal, lPos)
    End If
    
    If Len(sLink) = 0 Then
        ResolveFaviconURL = sServer & "favicon.ico"
        Exit Function
    End If

    lPos = InStrRev(sOriginal, "/")
    
    If Len(sServer) Then
        sPath = Left$(sOriginal, lPos)
    Else
        sServer = sOriginal & "/"
    End If

    If Left$(sLink, 2) = "//" Then
        ResolveFaviconURL = "http:" & sLink
        Exit Function
    End If
    
    If InStr(sLink, ":") > 0 Then
        ResolveFaviconURL = sLink
        Exit Function
    End If
    
    Do While Left$(sLink, 3) = "../"
        lPos = InStrRev(Left$(sPath, Len(sPath) - 1), "/")
        If lPos Then
            sPath = Left$(sPath, lPos)
            If Len(sPath) < Len(sServer) Then sPath = sServer
        End If
        sLink = Mid$(sLink, 4)
    Loop
    
    If Left$(sLink, 1) = "/" Then
        ResolveFaviconURL = sServer & Mid$(sLink, 2)
    Else
        If Len(sPath) Then
            ResolveFaviconURL = sPath & sLink
        Else
            ResolveFaviconURL = sServer & sLink
        End If
    End If

End Function

'es para decodificar los favicons que puedan tener envevidos en la url codificados en Base64
Private Function Base64Decode(ByVal vCode As String) As Byte()
    Dim oXML, oNode
    Dim vResults As Variant
    
    Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
    Set oNode = oXML.CreateElement("base64")
    oNode.dataType = "bin.base64"
    oNode.Text = vCode
    vResults = oNode.nodeTypedValue
    MoveArrayToVariant vResults, Base64Decode, False
    Set oNode = Nothing
    Set oXML = Nothing
End Function

'--------------------------------------------------------------------------------
'Lee una imagen (Png, jpg, bmp, etc.) desde un array de bits y devuelve un icono
'--------------------------------------------------------------------------------
Private Function CreateIconFromImageStream(ByRef bvData() As Byte, ByVal lWidth As Long, ByVal lHeight As Long) As Long
    
    Dim IStream     As IUnknown
    Dim gdiSI As GDIPlusStartupInput
    Dim TR          As RECTF
    Dim hIcon       As Long
    Dim ResizeBmp As Long
    Dim ResizeGra As Long
    Dim hBitmap As Long
    Dim gToken As Long
    
    On Local Error GoTo CreateIconFromImageStream_Error
    
    If Not IsArrayDim(VarPtrArray(bvData)) Then Exit Function

    Set IStream = CreateStream(bvData)
   
    If Not IStream Is Nothing Then
    
        gdiSI.GdiPlusVersion = 1&
        If GdiplusStartup(gToken, gdiSI) = 0 Then
       
            If GdipLoadImageFromStream(IStream, hBitmap) = 0 Then

                Call GdipGetImageBounds(hBitmap, TR, UnitPixel)
                
                If lWidth <> TR.Width Or lHeight <> TR.Height Then
            
                    If GdipCreateBitmapFromScan0(lWidth, lHeight, 0&, PixelFormat32bppARGB, ByVal 0&, ResizeBmp) = 0 Then
                    
                        If GdipGetImageGraphicsContext(ResizeBmp, ResizeGra) = 0 Then
                           
                            If GdipDrawImageRect(ResizeGra, hBitmap, 0, 0, lWidth, lHeight) = 0 Then
                                 
                                If GdipCreateHICONFromBitmap(ResizeBmp, hIcon) = 0 Then
                    
                                    CreateIconFromImageStream = hIcon
                    
                                End If
                                
                             End If
                            
                            Call GdipDeleteGraphics(ResizeGra)
                            
                        End If
                        
                        Call GdipDisposeImage(ResizeBmp)

                    End If
                Else
                
                   If GdipCreateHICONFromBitmap(hBitmap, hIcon) = 0 Then
                   
                        CreateIconFromImageStream = hIcon
                        
                   End If

                End If
    
                
            End If
            
            GdiplusShutdown gToken: gToken = 0
        End If
    End If

    Set IStream = Nothing
    
CreateIconFromImageStream_Error:

End Function

'------------------------------------------------------------------
'Lee una imagen ICO, CUR desde un array de bits y devuelve un icono
'------------------------------------------------------------------
Private Function LoadIconFromStream(ByRef bytIcoData() As Byte, ByVal lWidth As Long, ByVal lHeight As Long) As Long

    Dim tIconHeader     As IconHeader
    Dim tIconEntry()    As IconEntry
    Dim MaxBitCount     As Long
    Dim MaxSize         As Long
    Dim Aproximate      As Long
    Dim IconID          As Long
    Dim hIcon           As Long
    Dim i               As Long

  
    On Local Error GoTo LoadIconFromStream_Error
    
    If Not IsArrayDim(VarPtrArray(bytIcoData)) Then Exit Function

    Call CopyMemory(tIconHeader, bytIcoData(0), Len(tIconHeader))
    
    If tIconHeader.ihCount >= 1 Then
    
        ReDim tIconEntry(tIconHeader.ihCount - 1)
        
        Call CopyMemory(tIconEntry(0), bytIcoData(Len(tIconHeader)), Len(tIconEntry(0)) * tIconHeader.ihCount)
        
        IconID = -1
           
        For i = 0 To tIconHeader.ihCount - 1
            If tIconEntry(i).ieBitCount > MaxBitCount Then MaxBitCount = tIconEntry(i).ieBitCount
        Next
      
        For i = 0 To tIconHeader.ihCount - 1
            If MaxBitCount = tIconEntry(i).ieBitCount Then
                If IconID = -1 Then IconID = i
                MaxSize = CLng(tIconEntry(i).ieWidth) + CLng(tIconEntry(i).ieHeight)
                If MaxSize > Aproximate And MaxSize <= (lWidth + lHeight) Then
                    Aproximate = MaxSize
                    IconID = i
                End If
            End If
        Next
                   
        If IconID = -1 Then Exit Function
       
        With tIconEntry(IconID)
            hIcon = CreateIconFromResourceEx(bytIcoData(.ieImageOffset), .ieBytesInRes, 1, IconVersion, lWidth, lHeight, &H0)
            If hIcon <> 0 Then
                LoadIconFromStream = hIcon
            End If
        End With
       
    End If

LoadIconFromStream_Error:

End Function

Public Sub RenderStretchPlus(ByVal hGraphics As Long, _
                    ByVal DestX As Long, _
                    ByVal DestY As Long, _
                    ByVal DestW As Long, _
                    ByVal DestH As Long, _
                    ByVal hImage As Long, _
                    ByVal X As Long, _
                    ByVal Y As Long, _
                    ByVal Width As Long, _
                    ByVal Height As Long, _
                    ByVal Size As Long)
  
  

    Dim Sx2 As Long
  
    Sx2 = Size * 2
  

    Call GdipSetInterpolationMode(hGraphics, InterpolationModeNearestNeighbor)
    Call GdipSetPixelOffsetMode(hGraphics, PixelOffsetModeHalf)

    GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY, Size, Size, X, Y, Size, Size, &H2, 0&, 0&, 0& 'TOP_LEFT
    GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY, DestW - Sx2, Size, X + Size, Y, Width - Sx2, Size, &H2, 0&, 0&, 0& 'TOP_CENTER
    GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY, Size, Size, X + Width - Size, Y, Size, Size, &H2, 0&, 0&, 0& 'TOP_RIGHT
    GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + Size, Size, DestH - Sx2, X, Y + Size, Size, Height - Sx2, &H2, 0&, 0&, 0& 'MID_LEFT
    GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + Size, DestW - Sx2, DestH - Sx2, X + Size, Y + Size, Width - Sx2, Height - Sx2, &H2, 0&, 0&, 0& 'MID_CENTER
    GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY + Size, Size, DestH - Sx2, X + Width - Size, Y + Size, Size, Height - Sx2, &H2, 0&, 0&, 0& 'MID_RIGHT
    GdipDrawImageRectRectI hGraphics, hImage, DestX, DestY + DestH - Size, Size, Size, X, Y + Height - Size, Size, Size, &H2, 0&, 0&, 0& 'BOTTOM_LEFT
    GdipDrawImageRectRectI hGraphics, hImage, DestX + Size, DestY + DestH - Size, DestW - Sx2, Size, X + Size, Y + Height - Size, Width - Sx2, Size, &H2, 0&, 0&, 0& 'BOTTOM_CENTER
    GdipDrawImageRectRectI hGraphics, hImage, DestX + DestW - Size, DestY + DestH - Size, Size, Size, X + Width - Size, Y + Height - Size, Size, Size, &H2, 0&, 0&, 0& 'BOTTOM_RIGHT


  
End Sub
'las tres funciones a continuacion son de cobein,
'las he utilizado para crear un contador publico, pada poder habilitar o deshabilitar el click del webbrowser.
'el fin de esto es que si hay mas de una clase instanciada, no se habilite el sonido mientras otra esta trabajando.
Private Sub WriteValue(ByVal lProp As Long, ByVal lValue As Long)
    Dim lIndex As Long
    lIndex = GetIndex(lProp)
    If Not lIndex = -1 Then
        Call TlsSetValue(lIndex, lValue)
    End If
End Sub

'Autor: Cobein
Private Function ReadValue(ByVal lProp As Long) As Long
    Dim lIndex As Long
    lIndex = GetIndex(lProp)
    If Not lIndex = -1 Then
        ReadValue = TlsGetValue(lIndex)
    End If
End Function

'Autor: Cobein
Private Function GetIndex(ByVal lProp As Long) As Long
    Dim i       As Long
    Dim lIndex  As Long
    
    '// Try to find our property.
    lIndex = -1
    For i = 0 To TLS_MINIMUM_AVAILABLE - 1
        If TlsGetValue(i) = lProp Then
            lIndex = i + 1
            Exit For
        End If
    Next
    
    Dim lFlagIndex As Long
    
    '// No property found, allocate index.
    If lIndex = -1 Then
        Do
            lFlagIndex = TlsAlloc '// Find two consecutive slots
            lIndex = TlsAlloc
            If lIndex >= TLS_MINIMUM_AVAILABLE Then Exit Function
        Loop While Not lFlagIndex + 1 = lIndex
        Call TlsSetValue(lFlagIndex, lProp)
    End If
End Function

Private Function IsArrayDim(ByVal lpArray As Long) As Boolean
    Dim lAddress As Long
    Call CopyMemory(lAddress, ByVal lpArray, &H4)
    IsArrayDim = Not (lAddress = 0)
End Function

'Autor: LaVolpe
Private Function CreateStream(byteContent() As Byte, Optional byteOffset As Long = 0&) As stdole.IUnknown
    
    ' Purpose: Create an IStream-compatible IUnknown interface containing the
    ' passed byte aray. This IUnknown interface can be passed to GDI+ functions
    ' that expect an IStream interface -- neat hack
    
    On Error GoTo HandleError
    Dim o_lngLowerBound As Long
    Dim o_lngByteCount  As Long
    Dim o_hMem As Long
    Dim o_lpMem  As Long
     
    If Not IsArrayDim(VarPtrArray(byteContent)) Then  ' create a growing stream as needed
         Call CreateStreamOnHGlobal(0, 1, CreateStream)
    Else                                        ' create a fixed stream
         o_lngByteCount = UBound(byteContent) - byteOffset + 1
         o_hMem = GlobalAlloc(&H2&, o_lngByteCount)
         If o_hMem <> 0 Then
             o_lpMem = GlobalLock(o_hMem)
             If o_lpMem <> 0 Then
                 CopyMemory ByVal o_lpMem, byteContent(byteOffset), o_lngByteCount
                 Call GlobalUnlock(o_hMem)
                 Call CreateStreamOnHGlobal(o_hMem, 1, CreateStream)
             End If
         End If
     End If
    
HandleError:
End Function

'Autor: LaVolpe
Private Function ArrayFromStream(Stream As IUnknown, arrayBytes() As Byte) As Boolean

    ' Purpose: Return the array contained in an IUnknown interface
    
    Dim o_hMem As Long, o_lpMem As Long
    Dim o_lngByteCount As Long
    
    If Not Stream Is Nothing Then
    
        If GetHGlobalFromStream(ByVal ObjPtr(Stream), o_hMem) = 0 Then
            o_lngByteCount = GlobalSize(o_hMem)
            If o_lngByteCount > 0 Then
                o_lpMem = GlobalLock(o_hMem)
                If o_lpMem <> 0 Then
                    ReDim arrayBytes(0 To o_lngByteCount - 1)
                    CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
                    GlobalUnlock o_hMem
                    ArrayFromStream = True
                End If
            End If
        End If

    End If
    
End Function

'Autor: LaVolpe
Private Sub MoveArrayToVariant(inVariant As Variant, inArray() As Byte, Mount As Boolean)
    
    ' Variants are used a bit in this project to allow functions to receive
    ' multiple variable types (objects, strings, handles, arrays, etc) in a single parameter.
    ' When arrays are passed, don't want to unnecessarily copy the array
    ' if a copy isn't needed. But setting one variant to another that contains
    ' arrays, copies are made. With large arrays, performance suffers.
    ' So... this routine moves an array in/out of a variant and vice versa
    ' without making a copy of the array. We're just swapping pointers
    
    ' When mounting array to variant, the inVariant parameter can contain anything or nothing
    ' When dismounting array from variant, the inVariant parameter MUST contain a return byte array
    
    Dim bDummy() As Byte, srcAddr As Long, dstAddr As Long
    
    If Mount Then                                               ' moving array to variant
        inVariant = bDummy()                                    ' ensure target contains null byte array
        CopyMemory dstAddr, ByVal VarPtr(inVariant), 2&         ' get that null array's pointer
        If (dstAddr And VT_BYREF) Then
            CopyMemory dstAddr, ByVal VarPtr(inVariant) + 8&, 4&
        Else
            dstAddr = VarPtr(inVariant) + 8&
        End If
        srcAddr = VarPtrArray(inArray)                          ' get source array's pointer
        
    Else                                                        ' moving variant's array to array
    
        Erase inArray()                                         ' ensure source is nulled out
        CopyMemory srcAddr, ByVal VarPtr(inVariant), 2&         ' get source array's pointer
        If (srcAddr And VT_BYREF) Then
            CopyMemory srcAddr, ByVal VarPtr(inVariant) + 8&, 4&
        Else
            srcAddr = VarPtr(inVariant) + 8&
        End If
        dstAddr = VarPtrArray(inArray)                          ' get target array's pointer
    End If
    
    CopyMemory ByVal dstAddr, ByVal srcAddr, 4&                 ' swap pointers
    CopyMemory ByVal srcAddr, 0&, 4&                            ' null arrays have a null SafeArray pointer
    
End Sub



