Results 1 to 3 of 3

Thread: [VB6] - about Pointers and Bitmaps

  1. #1

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    [VB6] - about Pointers and Bitmaps

    i have 1 nice code for transparent AphaBlend, using Pointers
    these code gives me results(finally some result after very time trying working with pointers and bitmaps):
    Code:
    Option Explicit
    
    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 VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    
    Private Sub ChangeColors(Source As PictureBox, Destination As PictureBox, Alpha As Byte)
        Dim pic() As Byte
        Dim pic2() As Byte
        Dim sa As SAFEARRAY2D
        Dim bmp As BITMAP
        Dim bmp2 As BITMAP
        Dim r As Long, g As Long, b As Long
        Dim r2 As Long, g2 As Long, b2 As Long
        Dim i As Long, j As Long
        Dim BackColor As Long
        Dim a As Long
        Dim sa2 As SAFEARRAY2D
        
        'Source
        GetObjectAPI Source.Picture, Len(bmp), bmp
        
        With sa
            .cbElements = 1
            .cDims = 2
            .Bounds(0).lLbound = 0
            .Bounds(0).cElements = bmp.bmHeight
            .Bounds(1).lLbound = 0
            .Bounds(1).cElements = bmp.bmWidthBytes
            .pvData = bmp.bmBits
        End With
    
        CopyMemory ByVal VarPtrArray(pic), VarPtr(sa), 4
        
        'Destination
        GetObjectAPI Destination.Picture, Len(bmp2), bmp2
        
        With sa2
            .cbElements = 1
            .cDims = 2
            .Bounds(0).lLbound = 0
            .Bounds(0).cElements = bmp2.bmHeight
            .Bounds(1).lLbound = 0
            .Bounds(1).cElements = bmp2.bmWidthBytes
            .pvData = bmp2.bmBits
        End With
    
        CopyMemory ByVal VarPtrArray(pic2), VarPtr(sa2), 4
        
        BackColor = RGB(pic(0 + 2, 0), pic(0 + 1, 0), pic(0, 0))
        
        For i = 0 To UBound(pic, 1) - 3 Step 3
            For j = 0 To UBound(pic, 2)
                r = pic(i + 2, j)
                g = pic(i + 1, j)
                b = pic(i, j)
                
                If RGB(r, g, b) <> BackColor Then
                    r2 = pic2(i + 2, j)
                    g2 = pic2(i + 1, j)
                    b2 = pic2(i, j)
            
                    r = (Alpha * (r + 256 - r2)) / 256 + r2 - Alpha
                    g = (Alpha * (g + 256 - g2)) / 256 + g2 - Alpha
                    b = (Alpha * (b + 256 - b2)) / 256 + b2 - Alpha
                Else
                    r = pic2(i + 2, j)
                    g = pic2(i + 1, j)
                    b = pic2(i, j)
                End If
                If r > 255 Then r = 255
                If r < 0 Then r = 0
                If g > 255 Then g = 255
                If g < 0 Then g = 0
                If b > 255 Then b = 255
                If b < 0 Then b = 0
                
                pic2(i + 2, j) = r
                pic2(i + 1, j) = g
                pic2(i, j) = b
            Next j
        Next i
        
        CopyMemory ByVal VarPtrArray(pic), 0&, 4
        CopyMemory ByVal VarPtrArray(pic2), 0&, 4
        
        Destination.Refresh
    End Sub
    
    Private Sub Command1_Click()
        ChangeColors Picture1, Picture2, CByte(Text1.Text)
    End Sub
    heres the alpha calculation:
    Code:
    FinalPixel = (AlphaValue * (Source + 256 - Destination)) / 256 + Destination - AlphaValue
    the problem is the results
    because, the pic() position is 0,0, but in pic2() isn't. and seems that the pic() is, maybe, with height, but not with same width
    can anyone advice me?
    VB6 2D Sprite control

    To live is difficult, but we do it.

  2. #2

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: [VB6] - about Pointers and Bitmaps

    see these toturial
    Attached Images Attached Images
    VB6 2D Sprite control

    To live is difficult, but we do it.

  3. #3

    Thread Starter
    PowerPoster joaquim's Avatar
    Join Date
    Apr 2007
    Posts
    3,904

    Re: [VB6] - about Pointers and Bitmaps

    and these...
    Attached Files Attached Files
    VB6 2D Sprite control

    To live is difficult, but we do it.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width