Přehození dvou barev

Postup:
' Struktura pro informace o bitmapě
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

' Struktura pro informace SAFEARRAY
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

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


' Přehození dvou barev v PictureBoxu, který obsahuje 256-barevnou bitmapu
'
' Barvy do parametru se zadávají jako index barvy v barevné paletě obrázku, 
' paleta má 256 barev (index musí být v rozsahu 0-255).
Sub Swap2Colors(pictbox As PictureBox, ByVal color1 As Integer, _
    ByVal color2 As Integer)

    Dim pict() As Byte
    Dim sa As SafeArray2
    Dim bmp As BITMAP
    Dim r As Integer, c As Integer
    Dim value As Byte
    
    GetObjectAPI pictbox.Picture, Len(bmp), bmp

    If bmp.bmPlanes <> 1 Or bmp.bmBitsPixel <> 8 Then
        MsgBox "Pouze bitmapy o 256 barvách", vbCritical
        Exit Sub
    End If
    
    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
    
    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
    
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    
    pictbox.Refresh

End Sub

' Podpůrná procedura pro Swap2Colors
Private Function VarPtrArray(arr As Variant) As Long
    CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4
End Function

Zpět

Autor: The Bozena