Browse DevX
Sign up for e-mail newsletters from DevX

Tip of the Day
Language: VB5,VB6
Expertise: Advanced
Oct 20, 2001



Building the Right Environment to Support AI, Machine Learning and Deep Learning

SwapColorsArray - Swap all the colors in a 256-color bitmap

' This structure holds Bitmap information
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

' This structure holds SAFEARRAY info
Private Type SafeArray2
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    cElements1 As Long
    lLbound1 As Long
    cElements2 As Long
    lLbound2 As Long
End Type

' API declares
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest 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

' Change all the colors in the palette with another color in the same palette.

' The second argument is an array of Integers that specifies with which color
' each element must be replaced. For example if newColor(1) = 4 then the color 
' 1 in the
' palette with be replaced with color 4.
' Example:
'    ' prepare an array of colors that shift the color value by one
'    Dim newColors(255) As Integer
'    Dim i As Integer
'    For i = 0 To 255
'        newColors(i) = (i + 1) Mod 256
'    Next
'    SwapColorsArray Picture1, newColors

Sub SwapColorsArray(pictbox As PictureBox, newColors() As Integer)
    ' these are used to address the pixel using matrices
    Dim pict() As Byte
    Dim sa As SafeArray2
    Dim bmp As BITMAP
    Dim r As Integer, c As Integer
    Dim value As Byte
    ' get bitmap info
    GetObjectAPI pictbox.Picture, Len(bmp), bmp
    ' exit if not a supported bitmap
    If bmp.bmPlanes <> 1 Or bmp.bmBitsPixel <> 8 Then
        MsgBox "This routine supports 256-color bitmaps only", vbCritical
        Exit Sub
    End If
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .lLbound1 = 0
        .cElements1 = bmp.bmHeight
        .lLbound2 = 0
        .cElements2 = bmp.bmWidthBytes
        .pvData = bmp.bmBits
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' swap colors
    For r = 0 To UBound(pict, 1)
        For c = 0 To UBound(pict, 2)
            value = pict(r, c)
            If value >= 0 And value <= 255 Then
                pict(r, c) = newColors(value)
            End If
    ' destroy the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    ' inform VB that something has changed
End Sub

' Support routine for SwapColors

Private Function VarPtrArray(arr As Variant) As Long
    CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4
End Function

Francesco Balena
Comment and Contribute






(Maximum characters: 1200). You have 1200 characters left.



Thanks for your registration, follow us on our social networks to keep up-to-date