P°ehozenφ dvou barev
' 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