i have 1 nice code for transparent AphaBlend, using Pointers;)
these code gives me results(finally some result after very time trying working with pointers and bitmaps;)):
heres the alpha calculation:
the problem is the results:(
because, the pic() position is 0,0, but in pic2() isn't. and seems that the pic() is, maybe, with height, but not with same width:(
can anyone advice me?
these code gives me results(finally some result after very time trying working with pointers and bitmaps;)):
Code:
Option Explicit
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
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
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst 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
Private Sub ChangeColors(Source As PictureBox, Destination As PictureBox, Alpha As Byte)
Dim pic() As Byte
Dim pic2() As Byte
Dim sa As SAFEARRAY2D
Dim bmp As BITMAP
Dim bmp2 As BITMAP
Dim r As Long, g As Long, b As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim i As Long, j As Long
Dim BackColor As Long
Dim a As Long
Dim sa2 As SAFEARRAY2D
'Source
GetObjectAPI Source.Picture, Len(bmp), bmp
With sa
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp.bmWidthBytes
.pvData = bmp.bmBits
End With
CopyMemory ByVal VarPtrArray(pic), VarPtr(sa), 4
'Destination
GetObjectAPI Destination.Picture, Len(bmp2), bmp2
With sa2
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp2.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp2.bmWidthBytes
.pvData = bmp2.bmBits
End With
CopyMemory ByVal VarPtrArray(pic2), VarPtr(sa2), 4
BackColor = RGB(pic(0 + 2, 0), pic(0 + 1, 0), pic(0, 0))
For i = 0 To UBound(pic, 1) - 3 Step 3
For j = 0 To UBound(pic, 2)
r = pic(i + 2, j)
g = pic(i + 1, j)
b = pic(i, j)
If RGB(r, g, b) <> BackColor Then
r2 = pic2(i + 2, j)
g2 = pic2(i + 1, j)
b2 = pic2(i, j)
r = (Alpha * (r + 256 - r2)) / 256 + r2 - Alpha
g = (Alpha * (g + 256 - g2)) / 256 + g2 - Alpha
b = (Alpha * (b + 256 - b2)) / 256 + b2 - Alpha
Else
r = pic2(i + 2, j)
g = pic2(i + 1, j)
b = pic2(i, j)
End If
If r > 255 Then r = 255
If r < 0 Then r = 0
If g > 255 Then g = 255
If g < 0 Then g = 0
If b > 255 Then b = 255
If b < 0 Then b = 0
pic2(i + 2, j) = r
pic2(i + 1, j) = g
pic2(i, j) = b
Next j
Next i
CopyMemory ByVal VarPtrArray(pic), 0&, 4
CopyMemory ByVal VarPtrArray(pic2), 0&, 4
Destination.Refresh
End Sub
Private Sub Command1_Click()
ChangeColors Picture1, Picture2, CByte(Text1.Text)
End SubCode:
FinalPixel = (AlphaValue * (Source + 256 - Destination)) / 256 + Destination - AlphaValuebecause, the pic() position is 0,0, but in pic2() isn't. and seems that the pic() is, maybe, with height, but not with same width:(
can anyone advice me?