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
        Next
    Next
    
    ' destroy the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    
    ' inform VB that something has changed
    pictbox.Refresh
End Sub

' Support routine for SwapColors

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