Option Compare Database
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const WS_EX_TRANSPARENT = &H20&
Public Const LWA_ALPHA = &H2&
Public Enum FadeDirection
Fadein = -1
Fadeout = 0
Fadezero = 1
SetOpacity = 1
End Enum
Public Sub FadeForm(frm As Form, Optional Direction As FadeDirection = FadeDirection.Fadein, _
Optional iDelay As Integer = 0, Optional StartOpacity As Long = 5)
If frm Is Nothing Then: Exit Sub
On Error GoTo van
Dim lOriginalStyle As Long
Dim iCtr As Integer
If (frm.PopUp = True) Then
lOriginalStyle = GetWindowLong(frm.hWnd, GWL_EXSTYLE)
SetWindowLong frm.hWnd, GWL_EXSTYLE, lOriginalStyle Or WS_EX_LAYERED
If (lOriginalStyle = 0) And (Direction <> FadeDirection.SetOpacity) Then
FadeForm frm, SetOpacity, , StartOpacity
End If
Select Case Direction
Case FadeDirection.Fadezero
iCtr = StartOpacity
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
Case FadeDirection.Fadein
If StartOpacity < 1 Then StartOpacity = 1
For iCtr = StartOpacity To 255 Step 1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
DoEvents
' Debug.Print iCtr
Sleep iDelay
Next
Case FadeDirection.Fadeout
If StartOpacity < 6 Then StartOpacity = 255
For iCtr = StartOpacity To 1 Step -1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
DoEvents
Sleep iDelay
Next
Case Else
Select Case StartOpacity
Case Is < 1: StartOpacity = 1
Case Is > 255: StartOpacity = 255
End Select
SetLayeredWindowAttributes frm.hWnd, 0, CByte(StartOpacity), LWA_ALPHA
DoEvents
Sleep iDelay
End Select
Else
MsgBox "Forma mora biti Popup", vbOKOnly & vbInformation, "Ne
e ii"
End If
van:
End Sub