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

' This structure holds Bitmap informationPrivate Type BITMAP    bmType As Long    bmWidth As Long    bmHeight As Long    bmWidthBytes As Long    bmPlanes As Integer    bmBitsPixel As Integer    bmBits As LongEnd Type' This structure holds SAFEARRAY infoPrivate 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 LongEnd Type' API declaresPrivate 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, newColorsSub 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        Next    Next        ' destroy the local temporary array    CopyMemory ByVal VarPtrArray(pict), 0&, 4        ' inform VB that something has changed    pictbox.RefreshEnd Sub' Support routine for SwapColorsPrivate Function VarPtrArray(arr As Variant) As Long    CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4End Function

Share the Post:
Share on facebook
Share on twitter
Share on linkedin

Overview

Recent Articles: