using pointers on VB6

[cambalinho]

heres a sample of using pointers on VB6:

Option Explicit

Private Const BI_RGB = 0
Private Const CBM_INIT = &H4
Private Const DIB_RGB_COLORS = 0
Private Const USE_BITMAP_ALPHA = &H1000000

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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type



'Pointers:
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 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 GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long


' Note for VB5, change the lib name to "msvbvm50.dll"
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

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

Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As Any, ByVal iUsage As Long, lppvBits As Any, ByVal hSection As Long, ByVal dwOffset As Long) As Long

Private Declare Sub RtlFillMemory Lib "Kernel32.dll" ( _
ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Long)


Private HDCScreen As Long
Private OldBitmap As Long
Public MemoryHDC As Long
Public hBitmap As Long
Public width As Long
Public height As Long
Public PointerPixelData As Long
Private bmiInfo As BITMAPINFO
Private tSA As SAFEARRAY2D
Dim bDib() As Byte


Public Function NewImage(ByVal ImageWidth As Long, ByVal ImageHeight As Long) As Long
    If (width > 0) Then DeleteImage
    width = ImageWidth
    height = ImageHeight
    'Criar HDC
    HDCScreen = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    MemoryHDC = CreateCompatibleDC(HDCScreen)

    With bmiInfo.bmiHeader
        .biSize = Len(bmiInfo.bmiHeader)
        .biWidth = width
        .biHeight = -height ' is negative for start on top left pixel image
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
    End With
    ReDim Preserve bDib(0 To (width * 4) - 1, 0 To height - 1) 'yes we must redim and preserve the array
    hBitmap = CreateDIBSection(0, bmiInfo, DIB_RGB_COLORS, PointerPixelData, 0, 0)
    OldBitmap = SelectObject(MemoryHDC, hBitmap)

    'using pointers:
     ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        ' Height of the bitmap
        .Bounds(0).cElements = bmiInfo.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        ' Width of the bitmap in bits (see earlier):
        .Bounds(1).cElements = bmiInfo.bmiHeader.biWidth * 4
        .pvData = PointerPixelData
    End With
    ' Make the bDib() array point to the memory addresses:
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

End Function

Public Sub SetPixel(PosX As Long, PosY As Long, clrColor As Long)
    Dim RColor As Long
    Dim GColor As Long
    Dim BColor As Long
    RColor = GetRValue(clrColor)
    GColor = GetGValue(clrColor)
    BColor = GetBValue(clrColor)


    ' pre-multiply the R,G,B components by the alpha:
    ' by 4, because it's BGRA(DIB's aren't RGB, but BGR)
    bDib(PosX * 4, PosY) = BColor 'B
    bDib(PosX * 4 + 1, PosY) = GColor 'G
    bDib(PosX * 4 + 2, PosY) = RColor 'R
End Sub

Public Function GetPixel(PosX As Long, PosY As Long) As Long
    Dim RColor As Long
    Dim GColor As Long
    Dim BColor As Long
    On Error Resume Next

    'bDib(PosX + 3, PosY) = 0 'Alpha
    ' pre-multiply the R,G,B components by the alpha:
    BColor = bDib(PosX * 4, PosY) 'B
    GColor = bDib(PosX * 4 + 1, PosY) 'G
    RColor = bDib(PosX * 4 + 2, PosY) 'R
    GetPixel = RGB(RColor, GColor, BColor)
End Function

Public Sub DeleteImage()
    'Clear Brush:
    If (lBrush <> 0) Then
        SelectObject MemoryHDC, lOldBrush
        DeleteObject lBrush
    End If

    'Clear Pen:
    If (lPen <> 0) Then
        SelectObject MemoryHDC, lOldPen
        DeleteObject lPen
    End If

    'Clear pointer:
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4

    ' Antes de fechar o programa

    SelectObject MemoryHDC, OldBitmap
    DeleteObject hBitmap

    ' Ao finalizar o programa
    DeleteDC MemoryHDC
    DeleteDC HDCScreen
End Sub

on my Joaquimxxx account(because i haded problems on these account), someone ask me for i share these code.. and heres the code.
some declarations can be different, so i shared what i use ;)