Chunky by FelipeFS
It is currently Thu Feb 11, 2016 5:01 pm

All times are UTC

Post new topic  Reply to topic  [ 1 post ] 
Author Message
PostPosted: Fri Dec 28, 2012 5:56 pm 
Prolific Poster

Joined: Sat Apr 23, 2011 4:39 pm
Posts: 15
i'm trying using pointers with images(from Lucky's VB Gamming site), but by some reason i can't compare the values\pixels:(

Option Explicit

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbAlpha As Byte
End Type

    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 Function DIBRGB(ByVal c As Long) As Long
  DIBRGB = (c And &HFF&) * &H10000 Or (c And &HFF00&) Or (c And &HFF0000) \ &H10000
End Function

Private Function RGBValues(ByVal color As Long) As RGBQUAD  'find the rgb color values of a color
    Dim ReturnColor As RGBQUAD
    With ReturnColor
        .rgbRed = color And 255
        .rgbGreen = (color And 65535) \ 256
        .rgbBlue = (color And &HFF0000) \ 65536
        .rgbAlpha = ((color And &HFF000000) \ 16777216) And &HFF
    End With
    RGBValues = ReturnColor
End Function

Private Sub ChangeColors(pictbox As PictureBox, ByVal OldColor As Long, ByVal NewColor As Long)
    Dim pic() As Byte
    Dim sa As SAFEARRAY2D
    Dim bmp As BITMAP
    Dim r As Long, g As Long, b As Long
    Dim i As Long, j As Long
    Dim color1 As Long
    Dim color2 As RGBQUAD

    GetObjectAPI pictbox.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
    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) = OldColor Then
                Debug.Print "hi"
            End If
        Next j
    Next i
    CopyMemory ByVal VarPtrArray(pic), 0&, 4
    ' inform VB that something has changed
End Sub

Private Sub Command1_Click()
    ChangeColors Picture1, Picture2.BackColor, Picture3.BackColor
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Picture2.BackColor = Picture1.Point(x, y)
End Sub

Private Sub Picture3_Click()
    Picture3.BackColor = CommonDialog1.color
End Sub

can anyone tell me what isn't right?:(
i can't enter in that 'if', in ChangeColors() sub:(

Display posts from previous:  Sort by  
Post new topic  Reply to topic  [ 1 post ] 

All times are UTC

Who is online

Users browsing this forum: No registered users and 0 guests

You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  
Powered by phpBB® Forum Software © phpBB Limited