GFAlphaBlend/GFAlphaBlendfrm.frm
VERSION 5.00
Begin VB.Form GFAlphaBlendfrm
BorderStyle = 0 'Kein
Caption = "GFAlphaBlend"
ClientHeight = 90
ClientLeft = 0
ClientTop = 0
ClientWidth = 90
Enabled = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 90
ScaleWidth = 90
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows‑Standard
Visible = 0 'False
Begin VB.PictureBox GFABPicture3
Enabled = 0 'False
Height = 338
Left = 715
ScaleHeight = 285
ScaleWidth = 150
TabIndex = 2
Top = 65
Visible = 0 'False
Width = 208
End
Begin VB.PictureBox GFABPicture2
Enabled = 0 'False
Height = 338
Left = 390
ScaleHeight = 285
ScaleWidth = 150
TabIndex = 1
Top = 65
Visible = 0 'False
Width = 208
End
Begin VB.PictureBox GFABPicture1
Enabled = 0 'False
Height = 338
Left = 65
ScaleHeight = 285
ScaleWidth = 150
TabIndex = 0
Top = 65
Visible = 0 'False
Width = 208
End
End
Attribute VB_Name = "GFAlphaBlendfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001‑2003 by Louis. Functions to mix up two pictures or to manipulate a picture.
'
'NOTE: there are three ways to get a picture to mix (functions therefore provided by GFAlphaBlend code):
'(1) BitBlt()ing from a given hDC (GFAlphaBlend_FetchBlendPicture());
'(2) loading a picture from a file (GFAlphaBleng_LoadBlendPicture());
'(3) creating a colored area used to create e.g. flashes, etc. (GFAlphaBlend_CreateBlendPicture()).
'
'IMPORTANT: the target project should use GFAlphaBlend_IsAlphaBlendAvailable
'to verify this form's functions are usable. If not then the target project should support
'graphics operations that can be used instead of the alpha blending functions.
'All sub functions in this module that use AlphaBlend() must support error handling
'if any error occurs when calling AlphaBlend().
'
'GFAlphaBlend_DissolvePicture[1/2]
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
'GFAlphaBlend_MeltPicture[1/2]
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long 'faster than SetPixel() as it doesn't return color of painted pixel
'GFAlphaBlend_GetDesktophDC
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
'GFAlphaBlend_Blend
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal pBF As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFAlphaBlend_Fade
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'SE_DeletePictureBox
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
'GFDIBits_Dissolve
'Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw 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
'Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'other (mainly used by SE code)
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'SE_DeletePictureBox
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32s = 0
'GFDIBits_Dissolve
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 'color table in format RGB
'GFAlphaBlend_Blend
Private Type BLENDFUNCTION
BlendOperation As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
'SE_DeletePictureBox
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'DCStruct (mainly used by SE code)
Private Type DCStruct 'user‑defined
DC As Long
Width As Long 'PictureBox width (not picture width)
Height As Long 'PictureBox height (not picture height)
ObjectOldHandle As Long
End Type
'GFDIBits_Dissolve
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
'GFDIBits_Dissolve
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
'GFDIBits_Dissolve
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
'GFAlphaBlend_Blend
Const AC_SRC_OVER = &H0
'GFAlphaBlend_Sphere_[...]
Dim Sphere_PictureColorArray() As Long
Dim Sphere_RadiusArray() As Single
Dim Sphere_TranslationStructArray() As TranslationStruct
'SE_DeleteDCStruct
Dim NullDCStructVar As DCStruct 'use to reset any DCStruct var
'other
Dim Dissolve_PictureColorArray() As Long
Private Sub Form_Load()
'on error resume next
GFABPicture1.ScaleMode = vbPixels
GFABPicture1.AutoRedraw = True
GFABPicture2.ScaleMode = vbPixels
GFABPicture2.AutoRedraw = True
GFABPicture3.ScaleMode = vbPixels
GFABPicture3.AutoRedraw = True
End Sub
'*********************************BLEND IMAGE CREATION**********************************
'NOTE: there are three ways to get a blend picture, see annotation at top of this form.
'Always create both blend pictures before performing any blend operation.
'Always call GFAlphaBlend_CreateBlendPicture[1/2] AFTER fetching or loading the other
'blend image.
Public Function GFAlphaBlend_IsAlphaBlendAvailable() As Boolean
On Error GoTo Error: 'returns True if the API function AlphaBlend() is available (Win98), False if not (e.g. Win95)
Dim BLENDFUNCTIONVar As BLENDFUNCTION
'preset
BLENDFUNCTIONVar.BlendOperation = AC_SRC_OVER
BLENDFUNCTIONVar.BlendFlags = 0
BLENDFUNCTIONVar.SourceConstantAlpha = 128
BLENDFUNCTIONVar.AlphaFormat = 0
'begin
Call AlphaBlend(Me.hDC, 0, 0, 1, 1, GFABPicture3.hDC, 0, 0, 1, 1, VarPtr(BLENDFUNCTIONVar)) 'do any useless blending operation, jump to Error: if dll call is not possible
GFAlphaBlend_IsAlphaBlendAvailable = True 'ok
Exit Function
Error:
GFAlphaBlend_IsAlphaBlendAvailable = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_LoadBlendPicture1(ByVal LoadName As String) As Boolean
On Error GoTo Error: 'returns True for success or False for error
If Not ((Dir$(LoadName) = "") Or (Right$(LoadName, 1) = "\") Or (Len(LoadName) = 0)) Then 'verify
GFABPicture1.AutoSize = True
GFABPicture1.Picture = LoadPicture(LoadName)
GFABPicture1.AutoSize = False
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width)
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height)
GFAlphaBlend_LoadBlendPicture1 = True 'ok
Else
GFAlphaBlend_LoadBlendPicture1 = False 'error
End If
Exit Function
Error:
GFAlphaBlend_LoadBlendPicture1 = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_LoadBlendPicture2(ByVal LoadName As String) As Boolean
On Error GoTo Error: 'returns True for success or False for error
If Not ((Dir$(LoadName) = "") Or (Right$(LoadName, 1) = "\") Or (Len(LoadName) = 0)) Then 'verify
GFABPicture2.AutoSize = True
GFABPicture2.Picture = LoadPicture(LoadName)
GFABPicture2.AutoSize = False
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width)
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height)
GFAlphaBlend_LoadBlendPicture2 = True 'ok
Else
GFAlphaBlend_LoadBlendPicture2 = False 'error
End If
Exit Function
Error:
GFAlphaBlend_LoadBlendPicture2 = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_SaveBlendPicture1(ByVal SaveName As String) As Boolean
On Error GoTo Error: 'important 'returns True for success or False for error
'NOTE: when PictureBox.AutoRedraw = True then both a drawn and loaded picture can be saved accessing the .Image property
Call SavePicture(GFABPicture1.Image, SaveName)
GFAlphaBlend_SaveBlendPicture1 = True 'ok
Exit Function
Error:
GFAlphaBlend_SaveBlendPicture1 = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_SaveBlendPicture2(ByVal SaveName As String) As Boolean
On Error GoTo Error: 'important 'returns True for success or False for error
'NOTE: when PictureBox.AutoRedraw = True then both a drawn and loaded picture can be saved accessing the .Image property
Call SavePicture(GFABPicture2.Image, SaveName)
GFAlphaBlend_SaveBlendPicture2 = True 'ok
Exit Function
Error:
GFAlphaBlend_SaveBlendPicture2 = False 'error
Exit Function
End Function
Public Sub GFAlphaBlend_FetchBlendPicture1(ByVal FetchhDC As Long, ByVal FetchXPos As Long, ByVal FetchYPos As Long, ByVal FetchXSize As Long, ByVal FetchYSize As Long)
'on error resume next 'format: pixels
'preset
GFABPicture1.Width = (FetchXSize + 4) * Screen.TwipsPerPixelX
GFABPicture1.Height = (FetchYSize + 4) * Screen.TwipsPerPixelY
'GFABPicture1.AutoRedraw = False
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width)
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height)
'begin
Call BitBlt(GFABPicture1.hDC, 0, 0, FetchXSize, FetchYSize, FetchhDC, FetchXPos, FetchYPos, vbSrcCopy)
End Sub
Public Sub GFAlphaBlend_FetchBlendPicture2(ByVal FetchhDC As Long, ByVal FetchXPos As Long, ByVal FetchYPos As Long, ByVal FetchXSize As Long, ByVal FetchYSize As Long)
'on error resume next 'format: pixels
'preset
GFABPicture2.Width = (FetchXSize + 4) * Screen.TwipsPerPixelX
GFABPicture2.Height = (FetchYSize + 4) * Screen.TwipsPerPixelY
'GFABPicture2.AutoRedraw = False
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width)
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height)
'begin
Call BitBlt(GFABPicture2.hDC, 0, 0, FetchXSize, FetchYSize, FetchhDC, FetchXPos, FetchYPos, vbSrcCopy)
End Sub
Public Sub GFAlphaBlend_CreateBlendPicture1(ByVal PatternConst As Integer, ByVal PatternColor As Long)
'on error resume next
'
'NOTE: a special pattern is not supported at the moment.
'
'reset
Call SE_DeletePictureBox(GFABPicture1) 'msbugsave
'begin
GFABPicture1.Width = GFABPicture2.Width
GFABPicture1.Height = GFABPicture2.Height
GFABPicture1.BackColor = PatternColor
GFABPicture1.Picture = GFABPicture1.Image
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width) 'important
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height) 'important
End Sub
Public Sub GFAlphaBlend_CreateBlendPicture2(ByVal PatternConst As Integer, ByVal PatternColor As Long)
'on error resume next
'
'NOTE: a special pattern is not supported at the moment.
'
'reset
Call SE_DeletePictureBox(GFABPicture2) 'msbugsave
'begin
GFABPicture2.Width = GFABPicture1.Width
GFABPicture2.Height = GFABPicture1.Height
GFABPicture2.BackColor = PatternColor
GFABPicture2.Picture = GFABPicture2.Image
GFABPicture3.Width = MIN(GFABPicture1.Width, GFABPicture2.Width) 'important
GFABPicture3.Height = MIN(GFABPicture1.Height, GFABPicture2.Height) 'important
End Sub
Public Sub GFAlphaBlend_DissolvePicture1()
'on error resume next 'ready color data of GFABPicture1 into buffer
Dim hDC As Long
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
'
'NOTE: only one picture can be read into the buffer at a time.
'
'preset
If Not ((GFABPicture1.ScaleWidth < 1) Or (GFABPicture1.ScaleHeight < 1)) Then 'verify
ReDim Dissolve_PictureColorArray(0 To GFABPicture1.ScaleWidth ‑ 1, 0 To GFABPicture1.ScaleHeight ‑ 1) As Long
Else
Exit Sub 'error
End If
'begin
hDC = GFABPicture1.hDC 'store in local var to increase speed
For Temp1 = 0& To GFABPicture1.ScaleWidth ‑ 1&
For Temp2 = 0& To GFABPicture1.ScaleWidth ‑ 1&
Dissolve_PictureColorArray(Temp1, Temp2) = GetPixel(hDC, Temp1, Temp2)
Next Temp2
Next Temp1
'Call GFDIBits_Dissolve(hDC, GFABPicture1.ScaleWidth, GFABPicture1.ScaleHeight, ColorArray())
'Call OneToTwoDimArray(ColorArray(), Dissolve_PictureColorArray(), GFABPicture1.ScaleWidth, GFABPicture1.ScaleHeight)
Exit Sub
End Sub
Public Sub GFAlphaBlend_DissolvePicture2()
'on error resume next 'ready color data of GFABPicture2 into buffer
Dim hDC As Long
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
'
'NOTE: only one picture can be read into the buffer at a time.
'
'preset
If Not ((GFABPicture2.ScaleWidth < 1) Or (GFABPicture2.ScaleHeight < 1)) Then 'verify
ReDim Dissolve_PictureColorArray(0 To GFABPicture2.ScaleWidth ‑ 1, 0 To GFABPicture2.ScaleHeight ‑ 1) As Long
Else
Exit Sub 'error
End If
'begin
hDC = GFABPicture2.hDC 'store in local var to increase speed
For Temp1 = 0& To GFABPicture2.ScaleWidth ‑ 1&
For Temp2 = 0& To GFABPicture2.ScaleWidth ‑ 1&
Dissolve_PictureColorArray(Temp1, Temp2) = GetPixel(hDC, Temp1, Temp2)
Next Temp2
Next Temp1
'Call GFDIBits_Dissolve(hDC, GFABPicture2.ScaleWidth, GFABPicture2.ScaleHeight, ColorArray())
'Call OneToTwoDimArray(ColorArray(), Dissolve_PictureColorArray(), GFABPicture2.ScaleWidth, GFABPicture2.ScaleHeight)
Exit Sub
End Sub
Public Sub GFAlphaBlend_DissolveAnyPicture(ByVal TargethDC As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long)
'on error resume next 'ready color data of any hDC into buffer
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
'
'NOTE: only one picture can be read into the buffer at a time.
'
'preset
If Not ((TargetXSize < 1) Or (TargetYSize < 1)) Then 'verify
ReDim Dissolve_PictureColorArray(0 To TargetXSize ‑ 1, 0 To TargetYSize ‑ 1) As Long
Else
Exit Sub 'error
End If
'begin
For Temp1 = 0& To TargetXSize ‑ 1&
For Temp2 = 0& To TargetYSize ‑ 1&
Dissolve_PictureColorArray(Temp1, Temp2) = GetPixel(TargethDC, Temp1, Temp2)
Next Temp2
Next Temp1
'Call GFDIBits_Dissolve(TargethDC, TargetXSize, TargetYSize, ColorArray())
'Call OneToTwoDimArray(ColorArray(), Dissolve_PictureColorArray(), TargetXSize, TargetYSize)
'DEBUG
' Set Testfrm.Picture1.Picture = Nothing
' Erase ColorArray()
' Call TwoToOneDimArray(Dissolve_PictureColorArray(), ColorArray(), TargetXSize, TargetYSize)
' Call GFDIBits_Melt(TargethDC, TargetXSize, TargetYSize, ColorArray())
'END OF DEBUG
Exit Sub
End Sub
Public Sub GFAlphaBlend_MeltPicture1()
'on error resume next 'initializes GFABPicture1 with buffer content
Dim hDC As Long
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
Dim TargetXSize As Long
Dim TargetYSize As Long
'preset
TargetXSize = UBound(Dissolve_PictureColorArray(), 1)
TargetYSize = UBound(Dissolve_PictureColorArray(), 2)
GFABPicture1.Width = (UBound(Dissolve_PictureColorArray(), 1) + 4) * Screen.TwipsPerPixelX '4 pixels for borders
GFABPicture1.Height = (UBound(Dissolve_PictureColorArray(), 2) + 4) * Screen.TwipsPerPixelY '4 pixels for borders
'begin
hDC = GFABPicture1.hDC 'store in local var to increase speed
'Call TwoToOneDimArray(Dissolve_PictureColorArray(), ColorArray(), TargetXSize, TargetYSize)
'Call GFDIBits_Melt(hDC, TargetXSize, TargetYSize, ColorArray())
For Temp1 = 0& To TargetXSize ‑ 1&
For Temp2 = 0& To TargetYSize ‑ 1&
Call SetPixelV(hDC, Temp1, Temp2, Dissolve_PictureColorArray(Temp1, Temp2))
Next Temp2
Next Temp1
End Sub
Public Sub GFAlphaBlend_MeltPicture2()
'on error resume next 'initializes GFABPicture2 with buffer content
Dim hDC As Long
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
Dim TargetXSize As Long
Dim TargetYSize As Long
'preset
TargetXSize = UBound(Dissolve_PictureColorArray(), 1)
TargetYSize = UBound(Dissolve_PictureColorArray(), 2)
GFABPicture2.Width = (UBound(Dissolve_PictureColorArray(), 1) + 4) * Screen.TwipsPerPixelX '4 pixels for borders
GFABPicture2.Height = (UBound(Dissolve_PictureColorArray(), 2) + 4) * Screen.TwipsPerPixelY '4 pixels for borders
'begin
hDC = GFABPicture2.hDC 'store in local var to increase speed
'Call TwoToOneDimArray(Dissolve_PictureColorArray(), ColorArray(), TargetXSize, TargetYSize)
'Call GFDIBits_Melt(hDC, TargetXSize, TargetYSize, ColorArray())
For Temp1 = 0 To TargetXSize ‑ 1
For Temp2 = 0 To TargetYSize ‑ 1
Call SetPixelV(hDC, Temp1, Temp2, Dissolve_PictureColorArray(Temp1, Temp2))
Next Temp2
Next Temp1
End Sub
Public Sub GFAlphaBlend_MeltAnyPicture(ByVal TargethDC As Long)
'on error resume next 'initializes TargethDC with buffer content
Dim ColorArray() As Byte
Dim Temp1 As Long
Dim Temp2 As Long
Dim TargetXSize As Long
Dim TargetYSize As Long
'preset
TargetXSize = UBound(Dissolve_PictureColorArray(), 1) '+ 1& 'upper border 0‑based
TargetYSize = UBound(Dissolve_PictureColorArray(), 2) '+ 1& 'upper border 0‑based
'begin
'Call TwoToOneDimArray(Dissolve_PictureColorArray(), ColorArray(), TargetXSize, TargetYSize)
'Call GFDIBits_Melt(TargethDC, TargetXSize, TargetYSize, ColorArray())
For Temp1 = 0& To TargetXSize '‑ 1&
For Temp2 = 0& To TargetYSize '‑ 1&
Call SetPixelV(TargethDC, Temp1, Temp2, Dissolve_PictureColorArray(Temp1, Temp2))
Next Temp2
Next Temp1
End Sub
Public Function GFAlphaBlend_GetDesktopDC() As Long
'on error resume next
GFAlphaBlend_GetDesktopDC = GetWindowDC(GetDesktopWindow())
End Function
Public Function GFAlphaBlend_GetWindowDC(ByVal WindowHandle As Long) As Long
'on error resume next
GFAlphaBlend_GetWindowDC = GetWindowDC(WindowHandle)
End Function
'******************************END OF BLEND IMAGE CREATION******************************
'***********************************BLEND OPERATIONS************************************
Public Function GFAlphaBlend_Blend(ByVal TargethDC As Long, ByVal TargetXPos As Long, ByVal TargetYPos As Long, ByVal BlendFactor As Single) As Boolean
On Error GoTo Error: 'important; returns True for success or False for error
Dim BlendXSize As Long
Dim BlendYSize As Long
Dim BLENDFUNCTIONVar As BLENDFUNCTION
Dim BLENDFUNCTIONVarPointer As Long
'verify
If BlendFactor < ‑1! Then BlendFactor = ‑1!
If BlendFactor > 1! Then BlendFactor = 1!
'preset
BLENDFUNCTIONVar.BlendOperation = AC_SRC_OVER
BLENDFUNCTIONVar.BlendFlags = 0
BLENDFUNCTIONVar.SourceConstantAlpha = CByte(Abs(BlendFactor * 255!))
BLENDFUNCTIONVar.AlphaFormat = 0
'GFABPicture1.ScaleMode = vbPixels 'see Form_Load
'GFABPicture2.ScaleMode = vbPixels 'see Form_Load
BlendXSize = GFABPicture3.ScaleWidth
BlendYSize = GFABPicture3.ScaleHeight
Call CopyMemory(BLENDFUNCTIONVarPointer, BLENDFUNCTIONVar, Len(BLENDFUNCTIONVarPointer))
'begin
If Not (BlendFactor < 0!) Then
Call BitBlt(GFABPicture3.hDC, 0, 0, BlendXSize, BlendYSize, GFABPicture1.hDC, 0, 0, vbSrcCopy)
Call AlphaBlend(GFABPicture3.hDC, 0, 0, BlendXSize, BlendYSize, GFABPicture2.hDC, 0, 0, BlendXSize, BlendYSize, BLENDFUNCTIONVarPointer)
Call BitBlt(TargethDC, TargetXPos, TargetYPos, BlendXSize, BlendYSize, GFABPicture3.hDC, 0, 0, vbSrcCopy)
Else
Call AlphaBlend(GFABPicture1.hDC, 0, 0, BlendXSize, BlendYSize, GFABPicture2.hDC, 0, 0, BlendXSize, BlendYSize, BLENDFUNCTIONVarPointer)
Call BitBlt(TargethDC, TargetXPos, TargetYPos, BlendXSize, BlendYSize, GFABPicture1.hDC, 0, 0, vbSrcCopy)
End If
GFAlphaBlend_Blend = True 'ok
Exit Function
Error:
GFAlphaBlend_Blend = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_BlendDirect(ByVal TargethDC As Long, ByVal TargetXPos As Long, ByVal TargetYPos As Long, ByVal BlendFactor As Single) As Boolean
On Error GoTo Error: 'important; TargethDC is source and target of the blend operation, blend picture 1 must contain the second image; returns True for success or False for error
Dim BlendXSize As Long
Dim BlendYSize As Long
Dim BLENDFUNCTIONVar As BLENDFUNCTION
Dim BLENDFUNCTIONVarPointer As Long
'verify
If BlendFactor < ‑1! Then BlendFactor = ‑1!
If BlendFactor > 1! Then BlendFactor = 1!
'preset
BLENDFUNCTIONVar.BlendOperation = AC_SRC_OVER
BLENDFUNCTIONVar.BlendFlags = 0
BLENDFUNCTIONVar.SourceConstantAlpha = CByte(Abs(BlendFactor * 255!))
BLENDFUNCTIONVar.AlphaFormat = 0
'GFABPicture1.ScaleMode = vbPixels 'see Form_Load
'GFABPicture2.ScaleMode = vbPixels 'see Form_Load
BlendXSize = GFABPicture3.ScaleWidth
BlendYSize = GFABPicture3.ScaleHeight
Call CopyMemory(BLENDFUNCTIONVarPointer, BLENDFUNCTIONVar, Len(BLENDFUNCTIONVarPointer))
'begin
Call AlphaBlend(TargethDC, 0, 0, BlendXSize, BlendYSize, GFABPicture1.hDC, 0, 0, BlendXSize, BlendYSize, BLENDFUNCTIONVarPointer)
GFAlphaBlend_BlendDirect = True 'ok
Exit Function
Error:
GFAlphaBlend_BlendDirect = False 'error
Exit Function
End Function
Public Function GFAlphaBlend_Fade(ByVal TargethDC As Long, ByRef TargetObject As Object, ByVal TargetXPos As Long, ByVal TargetYPos As Long, ByVal FadeFrameNumber As Integer, ByVal FadeTimeTotal As Long, Optional ByVal ReverseFadeFlag As Boolean = False) As Boolean
On Error GoTo Error: 'important; returns True for success or False for error
Dim DCStructNumber As Integer
Dim DCStructArray() As DCStruct
Dim BlendFactor As Single
Dim BlendXSize As Long
Dim BlendYSize As Long
Dim FrameLoop As Integer
'
'NOTE: this function performs a fade animation on the target. The source images must
'be loaded into GFABPicture1 and GFABPicture2. As the API function AlphaBlend() is rather
'slow (Microsoft sucks) the fade images are pre‑created and cached in memory DCs.
'When the creation has finished the memory DC context is BitBlt()ed to the TargethDC
'in exactly the speed that is defined by the FadeFrameNumber and FadeTimeTotal
'values.
'If TargetObject is not Nothing then TargetObject.Refresh will be used during fading.
'
'verify
If (FadeFrameNumber < 1) Or (FadeFrameNumber > 32766) Then
GFAlphaBlend_Fade = False 'error
Exit Function
End If
'preset
DCStructNumber = FadeFrameNumber
ReDim DCStructArray(1 To DCStructNumber) As DCStruct
For FrameLoop = 1 To DCStructNumber
'
If ReverseFadeFlag = False Then
BlendFactor = (1! / CSng(FadeFrameNumber) * CSng(FrameLoop))
Else
BlendFactor = 1! ‑ (1! / CSng(FadeFrameNumber) * CSng(FrameLoop))
End If
'
'NOTE: GFABPicture3 is set to the final target image size whenever
'a fade picture is fetched/loaded/created.
'Transfer its content to the DCStructArray() to create a compatible DC only.
'
Call SE_PictureBoxToDCStruct(GFABPicture3, DCStructArray(FrameLoop))
Call GFAlphaBlend_Blend(GFABPicture3.hDC, 0, 0, BlendFactor)
GFABPicture3.Picture = GFABPicture3.Image 'important
Call SE_PictureBoxToDCStruct(GFABPicture3, DCStructArray(FrameLoop))
Call SE_DeletePictureBox(GFABPicture3) 'msbugsave
Next FrameLoop
'begin
For FrameLoop = 1 To DCStructNumber
BlendXSize = GFABPicture3.ScaleWidth
BlendYSize = GFABPicture3.ScaleHeight
Call BitBlt(TargethDC, TargetXPos, TargetYPos, BlendXSize, BlendYSize, DCStructArray(FrameLoop).DC, 0, 0, vbSrcCopy)
If Not (Int(CSng(FadeTimeTotal) / CSng(DCStructNumber)) < 1) Then
Call Sleep(Int(CSng(FadeTimeTotal) / CSng(DCStructNumber))) 'never use Sleep(0)
End If
If Not (TargetObject Is Nothing) Then
TargetObject.Refresh
End If
Next FrameLoop
'reset
For FrameLoop = 1 To DCStructNumber
Call SE_DeleteDCStruct(DCStructArray(FrameLoop))
Next FrameLoop
GFAlphaBlend_Fade = True 'ok
Exit Function
Error:
GFAlphaBlend_Fade = False 'error
Exit Function
End Function
'********************************END OF BLEND OPERATIONS********************************
'*********************************HIGH‑LEVEL FUNCTIONS**********************************
'NOTE: the following functions use the GFAlphaBlend functions to allow extended
'graphical picture manipulation.
Public Function GFAlphaBlend_AdjustBrightness(ByRef TargethDC As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long, ByVal BrightnessFactor As Single) As Boolean
'on error resume next 'returns True for success or False for error
'
'NOTE: call this sub to adjust the brightness of any picture.
'BrightnessFactor should range from 0 to 2, 1 means retain original brightness,
'e.g. 0.95 decreases the brightness a bit, e.g. 1.05 increases the brightness
'(0.05 should be a useful adjusting amount).
'
'verify
Select Case BrightnessFactor
Case Is < 0!
BrightnessFactor = 0!
Case Is > 2!
BrightnessFactor = 2!
End Select
'begin
Call GFAlphaBlend_FetchBlendPicture1(TargethDC, 0, 0, TargetXSize, TargetYSize)
If BrightnessFactor > 1! Then
Call GFAlphaBlend_CreateBlendPicture2(0, RGB(255, 255, 255))
Else
Call GFAlphaBlend_CreateBlendPicture2(0, 0)
End If
GFAlphaBlend_AdjustBrightness = GFAlphaBlend_Blend(TargethDC, 0, 0, Abs(BrightnessFactor ‑ 1!))
End Function
Public Function GFAlphaBlend_AdjustColor(ByRef TargethDC As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long, ByVal RFactor As Single, ByVal GFactor As Single, ByVal BFactor As Single, Optional ByVal DissolveTargetPictureFlag As Boolean = True) As Boolean
'on error resume next 'returns always True
Dim Temp1 As Long
Dim Temp2 As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim RAdd As Integer
Dim GAdd As Integer
Dim BAdd As Integer
'
'NOTE: the color adjusting cannot be done using the alpha blending functions.
'Instead the target picture is 'dissolved' and every single color value is
'manipulated in a loop.
'Note that this function is rather slow, so don't call it in a loop.
'
'verify
If RFactor < 0! Then RFactor = 0!
If GFactor < 0! Then GFactor = 0!
If BFactor < 0! Then BFactor = 0!
If RFactor > 2! Then RFactor = 2!
If GFactor > 2! Then GFactor = 2!
If BFactor > 2! Then BFactor = 2!
RAdd = CInt((RFactor ‑ 1!) * 128!)
GAdd = CInt((GFactor ‑ 1!) * 128!)
BAdd = CInt((BFactor ‑ 1!) * 128!)
'begin
'
If DissolveTargetPictureFlag = True Then
Call GFAlphaBlend_DissolveAnyPicture(TargethDC, TargetXSize, TargetYSize)
End If
'
For Temp1 = 0 To TargetXSize ‑ 1
For Temp2 = 0 To TargetYSize ‑ 1
'NOTE: tests showed that CopyMemory() is much faster than VB bit operations.
'R = 0 'not necessary
'G = 0 'not necessary
'B = 0 'not necessary
Call CopyMemory(R, Dissolve_PictureColorArray(Temp1, Temp2), 1&)
Call CopyMemory(G, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), 1&)
Call CopyMemory(B, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), 1&)
R = R + RAdd 'Integer addition is faster than Long addition (tested)
G = G + GAdd
B = B + BAdd
If R > 255 Then R = 255 'verifying is important
If R < 0 Then R = 0 '(otherwise displaying errors)
If G > 255 Then G = 255
If G < 0 Then G = 0
If B > 255 Then B = 255
If B < 0 Then B = 0
Call CopyMemory(Dissolve_PictureColorArray(Temp1, Temp2), R, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), G, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), B, 1&)
Next Temp2
Next Temp1
'
Call GFAlphaBlend_MeltAnyPicture(TargethDC)
GFAlphaBlend_AdjustColor = True 'ok
'
End Function
Public Function GFAlphaBlend_Colorize(ByRef TargethDC As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long, ByVal TargetColor As Long, Optional ByVal DissolveTargetPictureFlag As Boolean = True) As Boolean
'on error resume next 'returns always True
Dim Temp1 As Long
Dim Temp2 As Long
Dim Lightness As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim TargetR As Long
Dim TargetG As Long
Dim TargetB As Long
'
'NOTE: the coloring cannot be done using the alpha blending functions.
'Instead the target picture is 'dissolved' and every single color value is
'manipulated in a loop.
'Note that this function is rather slow, so don't call it in a loop.
'
'preset
Call CopyMemory(TargetR, TargetColor, 1&)
Call CopyMemory(TargetG, ByVal (VarPtr(TargetColor) + 1&), 1&)
Call CopyMemory(TargetB, ByVal (VarPtr(TargetColor) + 2&), 1&)
TargetR = TargetR \ 2& ‑ 64& 'subtract half of the maximum possible value to avoid lighting up picture
TargetG = TargetG \ 2& ‑ 64&
TargetB = TargetB \ 2& ‑ 64&
'begin
'
If DissolveTargetPictureFlag = True Then
Call GFAlphaBlend_DissolveAnyPicture(TargethDC, TargetXSize, TargetYSize)
End If
'
For Temp1 = 0 To TargetXSize ‑ 1
For Temp2 = 0 To TargetYSize ‑ 1
'NOTE: tests showed that CopyMemory() is much faster than VB bit operations.
'R = 0 'not necessary
'G = 0 'not necessary
'B = 0 'not necessary
Call CopyMemory(R, Dissolve_PictureColorArray(Temp1, Temp2), 1&)
Call CopyMemory(G, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), 1&)
Call CopyMemory(B, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), 1&)
Lightness = (R + G + B) \ 3&
R = Lightness + TargetR 'self‑invented
G = Lightness + TargetG
B = Lightness + TargetB
If R > 255 Then R = 255 'verifying is important
If R < 0 Then R = 0 '(otherwise displaying errors)
If G > 255 Then G = 255
If G < 0 Then G = 0
If B > 255 Then B = 255
If B < 0 Then B = 0
Call CopyMemory(Dissolve_PictureColorArray(Temp1, Temp2), R, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), G, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), B, 1&)
Next Temp2
Next Temp1
'
Call GFAlphaBlend_MeltAnyPicture(TargethDC)
GFAlphaBlend_Colorize = True 'ok
'
End Function
Public Function GFAlphaBlend_BorderFade(ByRef TargethDC As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long, ByVal BorderXSize As Long, ByVal BorderYSize As Long, ByVal BorderColor As Long) As Boolean
'on error resume next 'returns always True; creates an effect like 'Buttonize' in PSP 5.0
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim BorderColorR As Integer
Dim BorderColorG As Integer
Dim BorderColorB As Integer
Dim LS1 As Long 'loop start
Dim LS2 As Long
Dim LE1 As Long 'loop end
Dim LE2 As Long
Dim MixFactor As Single
Dim BorderLoop As Integer
Dim Temp1 As Long
Dim Temp2 As Long
'preset
Call CopyMemory(BorderColorR, BorderColor, 1&)
Call CopyMemory(BorderColorG, ByVal (VarPtr(BorderColor) + 1&), 1&)
Call CopyMemory(BorderColorB, ByVal (VarPtr(BorderColor) + 2&), 1&)
'begin
'
Call GFAlphaBlend_DissolveAnyPicture(TargethDC, TargetXSize, TargetYSize)
'
For BorderLoop = 1 To 4
'
Select Case BorderLoop
Case 1
LS1 = 0&
LE1 = TargetXSize ‑ 1&
LS2 = 0
LE2 = BorderYSize ‑ 1&
If LE2 > (TargetYSize / 2&) Then LE2 = (TargetYSize / 2&) 'important
Case 2
LS1 = 0&
LE1 = TargetXSize ‑ 1&
LS2 = TargetYSize ‑ BorderYSize ‑ 1&
LE2 = TargetYSize ‑ 1&
If LS2 < (TargetYSize / 2&) Then LS2 = (TargetYSize / 2&) 'important
Case 3
LS1 = 0&
LE1 = BorderXSize ‑ 1&
LS2 = 0&
LE2 = TargetYSize ‑ 1&
If LE1 > (TargetXSize / 2&) Then LE1 = (TargetXSize / 2&) 'important
Case 4
LS1 = TargetXSize ‑ BorderXSize ‑ 1&
LE1 = TargetXSize ‑ 1&
LS2 = 0&
LE2 = TargetYSize ‑ 1&
If LS1 < (TargetXSize / 2&) Then LS1 = (TargetXSize / 2&) 'important
End Select
'
For Temp1 = LS1 To LE1
For Temp2 = LS2 To LE2
'top border
Call CopyMemory(R, Dissolve_PictureColorArray(Temp1, Temp2), 1&)
Call CopyMemory(G, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), 1&)
Call CopyMemory(B, ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), 1&)
'
Select Case BorderLoop
Case 1
MixFactor = CSng(Temp2) / CSng(BorderYSize ‑ 1)
Case 2
MixFactor = 1! ‑ CSng(Temp2 ‑ (TargetYSize ‑ BorderYSize ‑ 1&)) / CSng(BorderYSize ‑ 1)
Case 3
MixFactor = CSng(Temp1) / CSng(BorderXSize ‑ 1)
Case 4
MixFactor = 1! ‑ CSng(Temp1 ‑ (TargetXSize ‑ BorderXSize ‑ 1&)) / CSng(BorderXSize ‑ 1)
End Select
'
R = CInt(((CSng(BorderColorR) * (1! ‑ MixFactor)) + (CSng(R) * (MixFactor)))) ' / 2!)
G = CInt(((CSng(BorderColorG) * (1! ‑ MixFactor)) + (CSng(G) * (MixFactor)))) ' / 2!)
B = CInt(((CSng(BorderColorB) * (1! ‑ MixFactor)) + (CSng(B) * (MixFactor)))) ' / 2!)
'
If R > 255 Then R = 255 'verifying is important
If R < 0 Then R = 0 '(otherwise displaying errors)
If G > 255 Then G = 255
If G < 0 Then G = 0
If B > 255 Then B = 255
If B < 0 Then B = 0
Call CopyMemory(Dissolve_PictureColorArray(Temp1, Temp2), R, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 1&), G, 1&)
Call CopyMemory(ByVal (VarPtr(Dissolve_PictureColorArray(Temp1, Temp2)) + 2&), B, 1&)
Next Temp2
Next Temp1
Next BorderLoop
'
Call GFAlphaBlend_MeltAnyPicture(TargethDC)
GFAlphaBlend_BorderFade = True 'ok
'
End Function
'***GFALPHABLEND SPHERE***
'
'NOTE: the GFAlphaBlend_Sphere code does not work yet.
'See also test project for further information about the sphere code.
'
'NOTE: the GFAlphaBlend_Sphere code is used to create an effect like seen
'in a Windows 98 screen saver named 'Science'.
'The created picture can be used to play an idle animation in any application.
'
'First call GFAlphaBlend_Sphere_Dissolve() to set the sphere radius, etc.
'and then GFAlphaBlend_Sphere_Create() to create the sphere effect in the
'dissolved picture.
Public Function GFAlphaBlend_Sphere_Dissolve(ByVal DissolvehDC As Long, ByVal DissolveXSize As Long, ByVal DissolveYSize As Long, ByVal SphereRadius As Long)
'on error resume next 'bugs inside here, brothers!
'preset
Call GFAlphaBlend_DissolveAnyPicture(DissolvehDC, DissolveXSize, DissolveYSize)
'begin
'
'DEBUG
' Debug.Print "UBound ‑ Dissolve[X/Y]Size"
' Debug.Print UBound(Dissolve_PictureColorArray(), 1) & "‑" & DissolveXSize
' Debug.Print UBound(Dissolve_PictureColorArray(), 2) & "‑" & DissolveYSize
' '
' 'NOTE: Dissolve_PictureColorArray() indices are 0‑based.
' 'Sphere_PictureColorArray() indices are 0‑based, too.
' '
'END OF DEBUG
'
ReDim Sphere_PictureColorArray(0 To (DissolveXSize ‑ 1), 0 To (DissolveYSize ‑ 1)) As Long
Call CopyMemory(Sphere_PictureColorArray(0, 0), Dissolve_PictureColorArray(0, 0), DissolveXSize * DissolveYSize * Len(Dissolve_PictureColorArray(0, 0)))
'
'DEBUG
' Dim X As Long
' Dim Y As Long
' For X = 1 To DissolveXSize
' For Y = 1 To DissolveYSize
' Testfrm.Picture2.PSet ((X ‑ 1) * Screen.TwipsPerPixelX, (Y ‑ 1) * Screen.TwipsPerPixelY), Sphere_PictureColorArray(X ‑ 1, Y ‑ 1)
' Next Y
' Next X
' Testfrm.Picture2.Refresh 'important
' Stop
'END OF DEBUG
'
'NOTE: the data in Sphere_PictureColorArray() is the same like in
'Dissolve_PictureColorArray() and will not be changed in any way.
'
Call Sphere_GetRadiusArray(SphereRadius, Sphere_RadiusArray())
'
'NOTE: the sphere radius array indices go from 1 to SphereRadius.
'
Call Sphere_GetTranslationStructArray(SphereRadius, Sphere_RadiusArray(), Sphere_TranslationStructArray())
Call Sphere_VerifyTranslationStructArray(Sphere_TranslationStructArray())
End Function
Public Function GFAlphaBlend_Sphere_Create(ByVal TargethDC As Long, ByVal SphereXPos As Long, ByVal SphereYPos As Long)
'on error resume next 'bugs inside here, brothers!
Dim UBound1 As Long
Dim UBound2 As Long
Dim Temp1 As Long
Dim Temp2 As Long
'preset
UBound1 = UBound(Sphere_PictureColorArray(), 1)
UBound2 = UBound(Sphere_PictureColorArray(), 2)
'begin
'
'Call CopyMemory(Sphere_PictureColorArray(0, 0), Dissolve_PictureColorArray(0, 0), UBound1 * UBound2 * Len(Dissolve_PictureColorArray(0, 0)))
'
For Temp1 = 1& To UBound(Sphere_TranslationStructArray(), 1)
For Temp2 = 1& To UBound(Sphere_TranslationStructArray(), 2)
If Not (Sphere_TranslationStructArray(Temp1, Temp2).XNew = ‑1) Then 'verify
If Not (Sphere_TranslationStructArray(Temp1, Temp2).YNew = ‑1) Then 'verify
'
If Not ((Sphere_TranslationStructArray(Temp1, Temp2).XNew + SphereXPos) < 0&) Then 'verify
If Not ((Sphere_TranslationStructArray(Temp1, Temp2).YNew + SphereYPos) < 0&) Then 'verify
If Not ((Sphere_TranslationStructArray(Temp1, Temp2).XNew + SphereXPos) > (UBound1 ‑ 1&)) Then 'verify
If Not ((Sphere_TranslationStructArray(Temp1, Temp2).YNew + SphereYPos) > (UBound2 ‑ 1&)) Then 'verify
'
Dissolve_PictureColorArray( _
Sphere_TranslationStructArray(Temp1, Temp2).XNew + SphereXPos, _
Sphere_TranslationStructArray(Temp1, Temp2).YNew + SphereYPos) = _
Sphere_PictureColorArray(Temp1 + SphereXPos, Temp2 + SphereYPos)
'
End If
End If
End If
End If
End If
End If
Next Temp2
Next Temp1
'
Call GFAlphaBlend_MeltAnyPicture(TargethDC)
'
End Function
'***END OF GFALPHABLEND SPHERE***
'******************************END OF HIGH‑LEVEL FUNCTIONS******************************
'*********************************SKIN ENGINE FUNCTIONS*********************************
'NOTE: the following functions have been copied from GFSkinEngine v1.0 (10‑28‑2001)
'as they provide exactly the functionality that is required by the GFAlphaBlend code.
Private Sub SE_DeleteDCStruct(ByRef DCStructVar As DCStruct)
'on error resume next 'NOTE: DCStructVar will not usable for BitBlt()ing anymore
Dim Temp As Long
Temp = SelectObject(DCStructVar.DC, DCStructVar.ObjectOldHandle)
Call DeleteObject(Temp)
Call DeleteDC(Temp)
Call DeleteObject(DCStructVar.DC)
Call DeleteDC(DCStructVar.DC)
DCStructVar = NullDCStructVar
End Sub
Private Sub SE_DeletePictureBox(ByRef PictureBox As PictureBox) 'copied from GFSkinEngine
'on error resume next 'verify MS's buggy picture box releases GUI memory
Dim OSVERSIONINFOVar As OSVERSIONINFO
'reset
PictureBox.Cls
Set PictureBox.Picture = Nothing
'verify
OSVERSIONINFOVar.dwOSVersionInfoSize = Len(OSVERSIONINFOVar)
Call GetVersionEx(OSVERSIONINFOVar)
If OSVERSIONINFOVar.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'NOTE: the following line leads to erros in WinNT but is necessary in Win98.
Call DeleteObject(PictureBox.Image.Handle) 'msbugsave
Call DeleteObject(PictureBox.Picture.Handle) 'msbugsave
End If
End Sub
Private Function SE_PictureBoxToDCStruct(ByRef PictureBox As PictureBox, ByRef DCStructVar As DCStruct) As Boolean
'On Error Resume Next 'returns True if transformation was successful, False if not
'NOTE: the Microsoft article Q129887 gives some information about a picture box's Image and Picture properties.
DCStructVar.DC = CreateCompatibleDC(PictureBox.hDC)
If Not (DCStructVar.DC = 0) Then
DCStructVar.ObjectOldHandle = SelectObject(DCStructVar.DC, PictureBox.Picture.Handle) 'do not BitBlt(), SelectObject() works fine (see GFMDIBackGround)
DCStructVar.Width = PictureBox.Width
DCStructVar.Height = PictureBox.Height
SE_PictureBoxToDCStruct = True 'ok
Else
SE_PictureBoxToDCStruct = False 'error
End If
End Function
'*****************************END OF SKIN ENGINE FUNCTIONS******************************
'***********************************GENERAL FUNCTIONS***********************************
'Private Function GFDIBits_Dissolve(ByVal DissolvehDC As Long, ByVal XSize As Long, ByVal YSize As Long, ByRef ColorArray() As Byte) As Boolean
' 'on error resume next 'fills passed array with hDC color data; returns true for success or False for error
' Dim BITMAPINFOVar As BITMAPINFO
' Dim TempDC As Long
' Dim TempBitmap As Long
' 'preset
' With BITMAPINFOVar.bmiHeader
' .biBitCount = 24
' .biCompression = BI_RGB
' .biPlanes = 1
' .biSize = Len(BITMAPINFOVar.bmiHeader)
' .biWidth = XSize
' .biHeight = YSize
' End With
' ReDim ColorArray(1 To BITMAPINFOVar.bmiHeader.biWidth * BITMAPINFOVar.bmiHeader.biHeight * 4) As Byte
' 'begin
' TempDC = CreateCompatibleDC(0)
' If TempDC = 0 Then GoTo Error: 'verify
' TempBitmap = CreateDIBSection(TempDC, BITMAPINFOVar, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
' If TempBitmap = 0 Then GoTo Error: 'verify
' If SelectObject(TempDC, TempBitmap) = 0 Then GoTo Error: 'verify
' If BitBlt(TempDC, 0, 0, BITMAPINFOVar.bmiHeader.biWidth, BITMAPINFOVar.bmiHeader.biHeight, DissolvehDC, 0, 0, vbSrcCopy) = 0 Then GoTo Error: 'verify
' If GetDIBits(TempDC, TempBitmap, 0, BITMAPINFOVar.bmiHeader.biHeight, ColorArray(1), BITMAPINFOVar, DIB_RGB_COLORS) = 0 Then GoTo Error: 'verify
' Call DeleteDC(TempDC)
' Call DeleteObject(TempBitmap)
' GFDIBits_Dissolve = True 'ok
' Exit Function
'Error:
' Call DeleteDC(TempDC) 'make sure memory is freed
' Call DeleteObject(TempBitmap) 'make sure memory is freed
' GFDIBits_Dissolve = False 'error
' Exit Function
'End Function
'
'Private Function GFDIBits_Melt(ByVal MelthDC As Long, ByVal XSize As Long, ByVal YSize As Long, ByRef ColorArray() As Byte) As Boolean
' 'on error resume next 'returns True for success, False if an error occurred
' Dim BITMAPINFOVar As BITMAPINFO
' 'preset
' With BITMAPINFOVar.bmiHeader
' .biBitCount = 24
' .biCompression = BI_RGB
' .biPlanes = 1
' .biSize = Len(BITMAPINFOVar.bmiHeader)
' .biWidth = XSize
' .biHeight = YSize
' End With
' 'begin
' GFDIBits_Melt = Not (SetDIBitsToDevice(MelthDC, 0, 0, XSize, YSize, 0, 0, 0, YSize, ColorArray(1), BITMAPINFOVar, DIB_RGB_COLORS) = 0)
'End Function
'*******************************END OF GENERAL FUNCTIONS********************************
'*****************************************OTHER*****************************************
'Private Sub OneToTwoDimArray(ByRef OneDimArray() As Byte, ByRef TwoDimArray() As Long, ByVal TargetXSize As Long, ByVal TargetYSize As Long)
' 'on error resume next 'converts the array used by GFDIBits_Dissolve
' Dim XFor As Long
' Dim YFor As Long
' '
' 'NOTE: the data of the array used by GFDIBits has the following format:
' 'BGRBGRBGR... (one‑dim array)
' 'The array data used by the other functions has the form:
' 'Array(x) = RGB(R, G, B).
' '
' 'preset
' ReDim TwoDimArray(0 To TargetXSize ‑ 1&, 0 To TargetYSize ‑ 1&) As Long
' 'begin
' For XFor = 1 To TargetXSize
' For YFor = 1 To TargetYSize
' TwoDimArray(XFor ‑ 1&, YFor ‑ 1&) = RGB( _
' OneDimArray(((YFor ‑ 1&) * TargetXSize + (XFor ‑ 1&)) * 3& + 1&), _
' OneDimArray(((YFor ‑ 1&) * TargetXSize + (XFor ‑ 1&)) * 3& + 2&), _
' OneDimArray(((YFor ‑ 1&) * TargetXSize + (XFor ‑ 1&)) * 3& + 3&))
' Next YFor
' Next XFor
'End Sub
'
'Private Sub TwoToOneDimArray(ByRef TwoDimArray() As Long, ByRef OneDimArray() As Byte, ByVal TargetXSize As Long, ByVal TargetYSize As Long)
' 'on error resume next 'converts the array used by GFDIBits_Dissolve
' Dim XFor As Long
' Dim YFor As Long
' Dim Temp As Long
' 'preset
' ReDim OneDimArray(1 To ((UBound(TwoDimArray(), 1) + 1&) * (UBound(TwoDimArray(), 2) + 1&) * 3&)) As Byte 'TwoDimArray()'s indices are 0‑based
' 'begin
' For YFor = 0 To TargetYSize ‑ 1&
' For XFor = 0 To TargetXSize ‑ 1& 'for some reason y loop first (tested)
' Call CopyMemory(OneDimArray(Temp + 1&), ByVal (VarPtr(TwoDimArray(XFor, YFor)) + 2&), 1) 'B
' Call CopyMemory(OneDimArray(Temp + 2&), ByVal (VarPtr(TwoDimArray(XFor, YFor)) + 1&), 1) 'G
' Call CopyMemory(OneDimArray(Temp + 3&), TwoDimArray(XFor, YFor), 1) 'R
' Temp = Temp + 3&
' Next XFor
' Next YFor
'End Sub
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'On Error Resume Next
If Value1 < Value2 Then
MIN = Value1
Else
MIN = Value2
End If
End Function
[END OF FILE]