Binaryworld - SwapColorsArray - Swap all the colors in a 256-color bitmap ... [ VB -> Graphics ]

' 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