[RESOLVED] [VB6- DIB's] - transparent opacy by pixel
i rebuild my code for do the opacy.
but i don't understand why takes so many time and the results aren't what i expected:(
Code:
Option Explicit
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Double
biClrUsed As Double
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As Long
End Type
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal dWidth As Long, ByVal dHeight _
As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As _
Long, ByVal SrcHeight As Long, lpBits As Any, lpBI As BITMAPINFO, _
ByVal wUsage As Long, ByVal RasterOp As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Dim bi32BitInfo As BITMAPINFO
Dim OriginalImage() As Long, ParentImage() As Long
Private Function DIBRGB(ByVal c As Long) As Long
DIBRGB = (c And &HFF&) * &H10000 Or (c And &HFF00&) Or (c And &HFF0000) \ &H10000
End Function
Public Sub DIBOpacy(Picture As Object, Parentpicture As Object, Alpha As Long, TransparentColor As Long, Optional PosX As Long = 0, Optional PosY As Long = 0)
Dim inWidth As Long
Dim inHeight As Long
Dim SrcRed As Long, SrcBlue As Long, SrcGreen As Long
Dim DstRed As Long, DstBlue As Long, DstGreen As Long
Dim R As Long, G As Long, B As Long
Dim x As Long, y As Long
inWidth = Picture.ScaleWidth
inHeight = Picture.ScaleHeight
ReDim OriginalImage(inWidth - 1, inHeight - 1)
ReDim ParentImage(inWidth - 1, inHeight - 1)
With bi32BitInfo.bmiHeader
.biBitCount = 32
.biPlanes = 1
.biSize = Len(bi32BitInfo.bmiHeader)
.biWidth = inWidth
.biHeight = inHeight
.biSizeImage = 4 * inWidth * inHeight
End With
TransparentColor = DIBRGB(TransparentColor)
GetDIBits Picture.hdc, Parentpicture.Image.Handle, 0, inHeight, OriginalImage(0, 0), bi32BitInfo, 0
GetDIBits Parentpicture.hdc, Parentpicture.Image.Handle, 0, inHeight, ParentImage(0, 0), bi32BitInfo, 0
Alpha = 255 - (Alpha * 255 / 100)
For y = 0 To inHeight - 1
For x = 0 To inWidth - 1
If OriginalImage(x, y) <> TransparentColor Then
DstBlue = ParentImage(x, y) And 255
DstGreen = (ParentImage(x, y) And 65535) \ 256
DstRed = (ParentImage(x, y) And &HFF0000) \ 65536
SrcBlue = OriginalImage(x, y) And 255
SrcGreen = (OriginalImage(x, y) And 65535) \ 256
SrcRed = (OriginalImage(x, y) And &HFF0000) \ 65536
R = (Alpha * (SrcRed + 256 - DstRed)) / 256 + DstRed - Alpha
G = (Alpha * (SrcGreen + 256 - DstGreen)) / 256 + DstGreen - Alpha
B = (Alpha * (SrcBlue + 256 - DstBlue)) / 256 + DstBlue - Alpha
ParentImage(x, y) = RGB(R, G, B)
Else
ParentImage(x, y) = TransparentColor
End If
Next x
Next y
StretchDIBits Parentpicture.hdc, PosX, PosY, inWidth, inHeight, 0, 0, _
inWidth, inHeight, ParentImage(0, 0), bi32BitInfo, 0, vbSrcCopy
End Sub
is the RGB calculation correct?
(i must calculate the DIB pixel to RGB(in these case is BGR) for combine the 2 pixeles)
Re: [VB6- DIB's] - transparent opacy by pixel
Code:
Option Explicit
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Double
biClrUsed As Double
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As Long
End Type
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal dWidth As Long, ByVal dHeight _
As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As _
Long, ByVal SrcHeight As Long, lpBits As Any, lpBI As BITMAPINFO, _
ByVal wUsage As Long, ByVal RasterOp As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Dim bi32BitInfo As BITMAPINFO
Dim OriginalImage() As Long, ParentImage() As Long
Private Function DIBRGB(ByVal c As Long) As Long
DIBRGB = (c And &HFF&) * &H10000 Or (c And &HFF00&) Or (c And &HFF0000) \ &H10000
End Function
'FinalPixel = (AlphaValue * (Source + 256 - Destination)) / 256 + Destination - AlphaValue
Public Sub DIBTransparentAlphaBlend(ByRef Picturehdc As Long, ByRef Picturehandle As Long, ByRef Parentpicturehdc As Long, ByRef Parentpicturehandle As Long, ByRef Alpha As Long, ByRef TransparentColor As Long, ByRef inWidth As Long, ByRef inHeight As Long)
Dim SrcRed As Long, SrcBlue As Long, SrcGreen As Long
Dim DstRed As Long, DstBlue As Long, DstGreen As Long
Dim R As Long, G As Long, B As Long
Dim x As Long, y As Long
ReDim OriginalImage(inWidth - 1, inHeight - 1)
ReDim ParentImage(inWidth - 1, inHeight - 1)
With bi32BitInfo.bmiHeader
.biBitCount = 32
.biPlanes = 1
.biSize = Len(bi32BitInfo.bmiHeader)
.biWidth = inWidth
.biHeight = inHeight
.biSizeImage = 4 * inWidth * inHeight
End With
TransparentColor = DIBRGB(TransparentColor)
GetDIBits Picturehdc, Picturehandle, 0, inHeight, OriginalImage(0, 0), bi32BitInfo, 0
GetDIBits Parentpicturehdc, Parentpicturehandle, 0, inHeight, ParentImage(0, 0), bi32BitInfo, 0
Alpha = 255 - (Alpha * 255 / 100)
'On Error Resume Next
For y = 0 To inHeight - 1
For x = 0 To inWidth - 1
If OriginalImage(x, y) <> TransparentColor Then
DstRed = ParentImage(x, y) And 255
DstGreen = (ParentImage(x, y) And 65535) \ 256
DstBlue = (ParentImage(x, y) And &HFF0000) \ 65536
SrcRed = OriginalImage(x, y) And 255
SrcGreen = (OriginalImage(x, y) And 65535) \ 256
SrcBlue = (OriginalImage(x, y) And &HFF0000) \ 65536
R = (Alpha * (SrcRed + 256 - DstRed)) / 256 + DstRed - Alpha
G = (Alpha * (SrcGreen + 256 - DstGreen)) / 256 + DstGreen - Alpha
B = (Alpha * (SrcBlue + 256 - DstBlue)) / 256 + DstBlue - Alpha
ParentImage(x, y) = RGB(R, G, B)
Else
ParentImage(x, y) = TransparentColor
End If
Next x
Next y
StretchDIBits Parentpicturehdc, 0, 0, inWidth, inHeight, 0, 0, _
inWidth, inHeight, ParentImage(0, 0), bi32BitInfo, 0, vbSrcCopy
End Sub
these sub works fine.. except the speed:(
maybe my problem is another... i will mark resolved.
thanks to all
