SwapColors – Swap any two 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' 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.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: