Private Type BlendFunction ' This structure holds the arguments required by Alphablend function to work
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
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 BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long) 'Conver to long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds 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 Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 SetDIBits Lib "gdi32" (ByVal hdc 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 CreateCompatibleDC 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 DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function StretchDIBits 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 wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BitmapInfo, ByVal wUsage As Long, ByVal dwRop 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
Sub CopyBackGroundIntoPictureBox()
Dim ThisWidth As Integer
Dim ThisHeight As Integer
Dim XCoord As Integer
Dim YCoord As Integer
XCoord = FadeAnswerPictureBox.Left
YCoord = FadeAnswerPictureBox.Top
ThisWidth = FadeAnswerPictureBox.ScaleWidth
ThisHeight = FadeAnswerPictureBox.ScaleHeight
FadeAnswerPictureBox.Visible = False
BitBlt FadeAnswerPictureBox.hdc, 0, 0, ThisWidth, ThisHeight, Form1.hdc, XCoord, YCoord, vbSrcCopy 'The part of form1 behind the picturebox
FadeAnswerPictureBox.Visible = True
End Sub
Sub PrintTranslucentText(ByVal ThisText As String, ThisOpacity As Integer)
CopyBackgroundFromMemory
FadeAnswerPictureBox.ForeColor = RGB(129, 0, 0)
DrawText FadeAnswerPictureBox.hdc, StringToPrint, Len(StringToPrint), ThisRectangle, DT_WORDBREAK ' Print text
AlphaBlendWithBackground (ThisOpacity)
FadeAnswerPictureBox.Refresh
End Sub
Sub FadeIn()
Dim Opacity As Integer
For Opacity = 0 To 160
PrintTranslucentText StringToPrint, Opacity
DoEvents: Sleep (1) ' Wait
Next Opacity
End Sub
Sub FadeOut()
Dim Opacity As Integer
For Opacity = 160 To 0 Step -1
PrintTranslucentText StringToPrint, Opacity
DoEvents: Sleep (1) ' Wait
Next Opacity
DoEvents: Sleep (2000)
End Sub
Private Sub Form_Activate()
Dim Opacity As Integer
SetRect ThisRectangle, 0, 0, FadeAnswerPictureBox.ScaleWidth, FadeAnswerPictureBox.ScaleHeight ' Set coordinates
FadeAnswerPictureBox.FontSize = 48
Form1.Refresh
CopyBackGroundIntoPictureBox 'The part of form 1 behind the picture box goes into the picture box
CopyBackgroundToMemory 'The picture box (part of form1) goes into memory to be used in Alphablending
Opacity = 127
OpacityScroll.Value = 127
PrintTranslucentText StringToPrint, Opacity
End Sub
Sub AlphaBlendWithBackground(ByVal BlendValue As Integer)
Dim ThisWidth As Integer
Dim ThisHeight As Integer
BF.BlendOp = AC_SRC_OVER
BF.BlendFlags = 0
BF.SourceConstantAlpha = 255 - BlendValue
BF.AlphaFormat = 0
RtlMoveMemory lBF, BF, 4 'Convert the BLENDFUNCTION-structure to a Long
