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 |
![]() |
Autor: The Bozena |