Imagen con cursor

holas encontré esta funcion para sacar imagen en jpg pero no logro que se vea el cursor alguien podría ayudarme.

Codigo del form:

Código

Option Explicit
 
 
' \\ -- Autor : Luciano Lodola -- http://www.recursosvisualbasic.com.ar
 
 
' \\ -- Declaraciones
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
' -- Clases para convertir el Bmp a Jpg
Private mImage                           As cImage
Private mJPG                             As cJpeg
 
' -- Capturar la pantalla y convertirla a JPG
''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Capturar_Guardar()
 
    On Error GoTo error_handler
 
    Dim lRet        As Long
    Dim lWidth      As Long
    Dim lHeight     As Long
 
    Me.MousePointer = vbHourglass
    Static iCount As Integer
    iCount = iCount + 1
 
    With Screen
        lWidth = .Width / .TwipsPerPixelX
        lHeight = .Height / .TwipsPerPixelY
    End With
 
    lRet = mImage.CopyHDC(GetDC(0), lWidth, lHeight)
    lRet = mJPG.SampleHDC(mImage.hDC, lWidth, lHeight)
    lRet = mJPG.SaveFile(App.Path & "\image_" & CStr(iCount) & ".jpg")
 
    Me.MousePointer = vbDefault
 
Exit Sub
error_handler:
Me.MousePointer = 0
End Sub
 
Private Sub Combo1_Click()
    mJPG.Quality = CLng(Combo1.Text)
End Sub
 
Private Sub Command1_Click()
    Call Capturar_Guardar
End Sub
 
' --------------------------------------------------------------------------
' \\ -- inicio
' --------------------------------------------------------------------------
Private Sub Form_Load()
    ' -- Inicializar variables
    Set mImage = New cImage
    Set mJPG = New cJpeg
    Command1.Caption = " Capturar pantalla "
 
    Combo1.ListIndex = Combo1.ListCount - 1
End Sub
' --------------------------------------------------------------------------
' \\ -- Fin
' --------------------------------------------------------------------------
 
Private Sub Form_Unload(Cancel As Integer)
    Set mImage = Nothing
    Set mJPG = Nothing
End Sub

cImage modulo de clase:

Código

Option Explicit
Option Base 0
 
'Class Name:    cImage.cls
'
'Description:   This class creates and gives access to a DIBSection for the
'               purpose of displaying and editing a digital image.
'
 
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 Type RGBQUAD
    rgbBlue           As Byte
    rgbGreen          As Byte
    rgbRed            As Byte
    rgbReserved       As Byte
End Type
Private Type BITMAPINFOHEADER
    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 BITMAPFILEHEADER
    bfType            As Integer
    bfSize            As Long
    bfReserved1       As Integer
    bfReserved2       As Integer
    bfOffBits         As Long
End Type
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 Type BITMAPINFO
    bmiHeader         As BITMAPINFOHEADER
    bmiColors(255)    As RGBQUAD
End Type
Private Type POINTAPI
        x As Long
        y As Long
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
Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long   'lplpVoid changed to ByRef
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) 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 Declare Function GetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (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 PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
 
 
Private Const BLACKONWHITE    As Long = 1 'nStretchMode constants for
Private Const COLORONCOLOR    As Long = 3 '  SetStretchBltMode() API function
Private Const HALFTONE        As Long = 4 'HALFTONE not supported in Win 95, 98, ME
 
Private Const BI_RGB          As Long = 0&
Private Const BI_RLE4         As Long = 2&
Private Const BI_RLE8         As Long = 1&
Private Const DIB_RGB_COLORS  As Long = 0
 
Private m_hDIb        As Long       ' Handle to the current DIBSection
Private m_hBmpOld     As Long       ' Handle to the old bitmap in the DC, for clear up
Private m_hDC         As Long       ' Handle to the Device context holding the DIBSection
Private m_Ptr         As Long       ' Address of memory pointing to the DIBSection's bits
Private m_BI          As BITMAPINFO ' Type containing the Bitmap information
Private m_RGB(255)    As RGBQUAD
 
 
 
Private Sub Clear()
    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_Ptr = 0
End Sub
Private Sub Class_Terminate()
    Clear
End Sub
 
 
 
'====================================================================================
'                                PUBLIC PROPERTIES
'====================================================================================
Public Property Get Width() As Long
    Width = m_BI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_BI.bmiHeader.biHeight
End Property
Public Property Get BitCount() As Integer
    BitCount = m_BI.bmiHeader.biBitCount
End Property
Public Property Get hDC() As Long
    hDC = m_hDC
End Property
Public Property Get DIBitsPtr() As Long
    DIBitsPtr = m_Ptr
End Property
Public Property Get BytesPerScanLine() As Long
    Select Case m_BI.bmiHeader.biBitCount ' Scans must align on 4-byte boundaries
    Case 1:    BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 8 + 4) And &HFFFFFFFC
    Case 4:    BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 2 + 4) And &HFFFFFFFC
    Case 8:    BytesPerScanLine = (m_BI.bmiHeader.biWidth + 3) And &HFFFFFFFC
    Case Else: BytesPerScanLine = (m_BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
    End Select
End Property
 
 
 
'====================================================================================
'                             DIMENSION / COLOR DEPTH
'====================================================================================
Public Function Create(lWidth As Long, lHeight As Long, iBitCount As Integer) As Boolean
    Clear                        'Set Dimensions and BitCount in this cImage
    Select Case iBitCount
    Case 24
        m_hDC = CreateCompatibleDC(0)
    Case 1, 4, 8
        Dim lHDCDesk As Long
        lHDCDesk = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
        m_hDC = CreateCompatibleDC(lHDCDesk)
        DeleteDC lHDCDesk
    End Select
    If m_hDC = 0 Then Exit Function
    With m_BI.bmiHeader
        .biSize = Len(m_BI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = iBitCount
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    If iBitCount <> 24 Then ' Create a default grayscale palette
        Dim i As Long
        Dim c As Long
        c = 2 ^ iBitCount - 1
        For i = 0 To c
            With m_BI.bmiColors(i)
                .rgbBlue = i * 255# / c
                .rgbGreen = .rgbBlue
                .rgbRed = .rgbBlue
            End With
        Next i
    End If
    m_hDIb = CreateDIBSection2(m_hDC, m_BI, DIB_RGB_COLORS, m_Ptr, 0, 0)
    If m_hDIb = 0 Then
        DeleteObject m_hDC
    Else
        m_hBmpOld = SelectObject(m_hDC, m_hDIb)
        Create = True
    End If
End Function
 
 
 
'====================================================================================
'                                 LOAD/COPY IMAGE
'====================================================================================
Public Function CopyStdPicture(ByRef TheStdPicture As StdPicture, Optional iBitCount As Integer) As Boolean
    Dim lHDC         As Long
    Dim lhDCDesktop  As Long
    Dim lhBmpOld     As Long
    Dim tBMP         As BITMAP
    Dim CopyPalette  As Boolean
 
    GetObjectAPI TheStdPicture.handle, Len(tBMP), tBMP
 
    CopyPalette = (iBitCount = 0)
    If CopyPalette Then
        iBitCount = tBMP.bmBitsPixel
        If iBitCount = 16 Then iBitCount = 24
    End If
 
    If Not Create(tBMP.bmWidth, tBMP.bmHeight, iBitCount) Then Exit Function
 
    If m_BI.bmiHeader.biBitCount = 24 Then
        lhDCDesktop = GetDC(GetDesktopWindow())
    Else
        lhDCDesktop = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    End If
    If lhDCDesktop = 0 Then Exit Function
 
    lHDC = CreateCompatibleDC(lhDCDesktop)
    DeleteDC lhDCDesktop
    If lHDC = 0 Then Exit Function
    lhBmpOld = SelectObject(lHDC, TheStdPicture.handle)
    If m_BI.bmiHeader.biBitCount = 24 Then
        BitBlt m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, lHDC, 0, 0, vbSrcCopy
    Else
        If CopyPalette Then
            Dim lC As Long
            Dim C2 As Long
            C2 = 2 ^ m_BI.bmiHeader.biBitCount
            lC = GetDIBColorTable(lHDC, 0, C2, m_RGB(0))
            If (lC > 0) Then SetDIBColorTable m_hDC, 0, lC, m_RGB(0)
        End If
        GetDIBits256 lHDC, TheStdPicture.handle, 0, tBMP.bmHeight, ByVal m_Ptr, m_BI, DIB_RGB_COLORS
    End If
    SelectObject lHDC, lhBmpOld
    DeleteObject lHDC
    CopyStdPicture = True
End Function
Public Function CopyHDC(ByVal lHDC As Long, lWidth As Long, lHeight As Long, Optional ByVal iBitCount As Integer, Optional lSrcLeft As Long, Optional lSrcTop As Long) As Boolean
    Dim C1 As Long
    If iBitCount = 0 Then
        C1 = GetDIBColorTable(lHDC, 0, 256, m_RGB(0))
        Select Case C1
        Case 1 To 2:     iBitCount = 1
        Case 3 To 16:    iBitCount = 4
        Case 17 To 256:  iBitCount = 8
        Case Else:       iBitCount = 24
        End Select
    End If
    If Not Create(lWidth, lHeight, iBitCount) Then Exit Function
    If C1 > 0 Then SetDIBColorTable m_hDC, 0, C1, m_RGB(0)
    BitBlt m_hDC, 0, 0, lWidth, lHeight, lHDC, lSrcLeft, lSrcTop, vbSrcCopy
    CopyHDC = True
End Function
 
Public Function CopyPalletHDC(ByVal lHDC As Long) As Boolean
    Dim g As Long
 
    g = GetDIBColorTable(lHDC, 0, 2 ^ m_BI.bmiHeader.biBitCount, m_RGB(0))
    If g > 0 Then CopyPalletHDC = (g = SetDIBColorTable(m_hDC, 0, g, m_RGB(0)))
End Function
 
 
 
'====================================================================================
'                              PAINT/PASTE SECTIONS
'====================================================================================
Public Sub PaintHDC(lHDC As Long, Optional lDestLeft As Long, Optional lDestTop As Long, Optional eRop As RasterOpConstants = vbSrcCopy)
    BitBlt lHDC, lDestLeft, lDestTop, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_hDC, 0, 0, eRop
End Sub
 
 
 
'====================================================================================
'                               DISPLAY FUNCTIONS
'====================================================================================
'The following functions return modified versions of this class for display purposes.
'They are not meant to be used as reliable image processing routines, because the
'PlgBlt() and StretchBlt() API calls are not precise.
 
Public Function Greyscale() As cImage
    Set Greyscale = New cImage        'Return 8 bit Greyscale version of this cImage
    Greyscale.Create m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 8
    BitBlt Greyscale.hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_hDC, 0, 0, vbSrcCopy
End Function
 
Public Function Resample(lWidth As Long, lHeight As Long) As cImage
    Set Resample = New cImage         'Return a resized version of this cImage
    Resample.Create lWidth, lHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Resample.CopyPalletHDC m_hDC
 
    If (lWidth = m_BI.bmiHeader.biWidth) And (lHeight = m_BI.bmiHeader.biHeight) Then
       'Just return a copy
        BitBlt Resample.hDC, 0, 0, lWidth, lHeight, m_hDC, 0, 0, vbSrcCopy
    Else
       'HALFTONE gives better quality at slower speed, but it's unsupported in Win 95, 98, ME.
       'If we can't use HALFTONE, use COLORONCOLOR.  The default BLACKONWHITE is unacceptable.
        If SetStretchBltMode(Resample.hDC, HALFTONE) = 0 Then SetStretchBltMode Resample.hDC, COLORONCOLOR
        StretchBlt Resample.hDC, 0, 0, lWidth, lHeight, m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, vbSrcCopy
    End If
End Function
 
Public Function Mirror(Vertical As Boolean) As cImage
    Dim MyPoint(2) As POINTAPI 'Return a mirror image of this cImage
 
    If Vertical Then
        MyPoint(0).x = 0
        MyPoint(0).y = m_BI.bmiHeader.biHeight
        MyPoint(1).x = m_BI.bmiHeader.biWidth
        MyPoint(1).y = m_BI.bmiHeader.biHeight
        MyPoint(2).x = 0
        MyPoint(2).y = 0
    Else
        MyPoint(0).x = m_BI.bmiHeader.biWidth
        MyPoint(0).y = 0
        MyPoint(1).x = 0
        MyPoint(1).y = 0
        MyPoint(2).x = m_BI.bmiHeader.biWidth
        MyPoint(2).y = m_BI.bmiHeader.biHeight
    End If
 
    Set Mirror = New cImage
    Mirror.Create m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Mirror.CopyPalletHDC m_hDC
    PlgBlt Mirror.hDC, MyPoint(0), m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 0, 0, 0
End Function
 
Public Function Rotate(ByVal Degrees As Long) As cImage
    Dim NewWidth     As Long 'Return version of this cImage rotated Degrees
    Dim NewHeight    As Long
    Dim MyPoint(2)   As POINTAPI
 
    Degrees = Degrees Mod 360
    If Degrees < 0 Then Degrees = Degrees + 360
 
    Select Case Degrees
    Case 90
        MyPoint(0).x = 0
        MyPoint(0).y = m_BI.bmiHeader.biWidth
        MyPoint(1).x = 0
        MyPoint(1).y = 0
        MyPoint(2).x = m_BI.bmiHeader.biHeight
        MyPoint(2).y = m_BI.bmiHeader.biWidth
        NewWidth = m_BI.bmiHeader.biHeight
        NewHeight = m_BI.bmiHeader.biWidth
    Case 180
        MyPoint(0).x = m_BI.bmiHeader.biWidth
        MyPoint(0).y = m_BI.bmiHeader.biHeight
        MyPoint(1).x = 0
        MyPoint(1).y = m_BI.bmiHeader.biHeight
        MyPoint(2).x = m_BI.bmiHeader.biWidth
        MyPoint(2).y = 0
        NewWidth = m_BI.bmiHeader.biWidth
        NewHeight = m_BI.bmiHeader.biHeight
    Case 270
        MyPoint(0).x = m_BI.bmiHeader.biHeight
        MyPoint(0).y = 0
        MyPoint(1).x = m_BI.bmiHeader.biHeight
        MyPoint(1).y = m_BI.bmiHeader.biWidth
        MyPoint(2).x = 0
        MyPoint(2).y = 0
        NewWidth = m_BI.bmiHeader.biHeight
        NewHeight = m_BI.bmiHeader.biWidth
    Case Else
        Exit Function
    End Select
 
    Set Rotate = New cImage
    Rotate.Create NewWidth, NewHeight, m_BI.bmiHeader.biBitCount
    If m_BI.bmiHeader.biBitCount <> 24 Then Rotate.CopyPalletHDC m_hDC
    PlgBlt Rotate.hDC, MyPoint(0), m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, 0, 0, 0
End Function

cJpeg modulo de clase: lo dejo en comentario porque no me deja el limite.