Binaryworld - SwapColors - Swap any two 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

' Swap two colors in a PictureBox that holds a 256-color bitmap
'
' the two color arguments are the indexes of the colors to be swapper in
' the 256 palette (must be in the range 0-255).

Sub SwapColors(pictbox As PictureBox, ByVal color1 As Integer, _
  ByVal color2 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 = color1 Then
        pict(r, c) = color2
      ElseIf value = color2 Then
        pict(r, c) = color1
      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