[RESOLVED] flicker on fading form
I am trying to work out the kinks on a form that fades to replace my OK message boxs. It does a slight flicker randomly when the fade starts. It does not do it all the time, in testing
Flickered 5 out of 10 times.
Flickered 3 out of 10 times.
Flickered 4 out of 10 times.
I can not determine what is causing this. Help Please
Code:
Private Sub Command2_Click()
gMsg = "The John Doe bid has been saved"
Load frmMessageBox
Set frmMessageBox = Nothing 'had to add this to allow rerunning the this code with out unloading this form
End Sub
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Sub Form_Initialize()
Call SetLabelMessage
Call FormLoadSub
End Sub
Sub FormLoadSub()
Dim dTime1 As Date
DoEvents
GradObj Me 'fills form with gradient
Me.show
dTime1 = Now
Do
DoEvents
Loop Until DateDiff("s", dTime1, Now) >= 3
Unload Me
End Sub
Sub SetLabelMessage()
DoEvents
If gMsg <> "" Then 'change the message if needed
lblMessage.Caption = gMsg
lblMessage.Left = (Me.Width - lblMessage.Width) / 2 'Center the message
Me.Refresh
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call fade(False)
End Sub
Public Sub fade(ByVal show As Boolean)
Dim lngStyle As Long, bytLoop As Integer
Dim min As Integer, max As Integer, stepVal As Integer
lngStyle = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
lngStyle = lngStyle Xor WS_EX_LAYERED
If (lngStyle And WS_EX_LAYERED) <> 0 Then
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, lngStyle)
End If
If show Then
min = 0
max = 255
stepVal = 1
Me.show
DoEvents
Else
min = 255
max = 0
stepVal = -1
End If
For bytLoop = min To max Step stepVal
Call SetLayeredWindowAttributes(Me.hWnd, 0, bytLoop, LWA_ALPHA)
DoEvents
Next bytLoop
gMsg = ""
Unload Me
End Sub
Re: flicker on fading form
To prevent flickering use LockWindowUpdate API.
Code:
Declare Function LockWindowUpdate Lib "user32" Alias "LockWindowUpdate" (ByVal hwndLock As Long) As Long
Re: flicker on fading form
Quote:
Originally Posted by dee-u
To prevent flickering use LockWindowUpdate API.
Code:
Declare Function LockWindowUpdate Lib "user32" Alias "LockWindowUpdate" (ByVal hwndLock As Long) As Long
Thanks
I have used that for dragging, but it doesn't work in this case
Re: flicker on fading form
Quote:
Originally Posted by isnoend07
Thanks
I have used that for dragging, but it doesn't work in this case
Try calling the translucent API routine on form load, that's what seems to fixed it for me, without doing that I had same flicker problem. Here's basically what I been using....
Code:
Option Explicit
Private Sub Form_Load()
TranslucentForm Me, 0 ' make me transparent ' 255 = solid
Me.Show
DoEvents
DoFade Me, True ' fade in
End Sub
Private Sub Command2_Click()
' fade out
DoFade Me, False
End Sub
Code:
Option Explicit
' Translucent
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) _
As Long
Private Declare Function SetLayeredWindowAttributes Lib _
"user32" (ByVal hwnd As Long, ByVal crKey As Long, _
ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'Zzzzzz___
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoFade(Frm As Form, FadeIn As Boolean)
' // Fade form in or out //
Dim X As Integer
Frm.Enabled = False
If FadeIn = False Then
For X = 145 To 0 Step -5
TranslucentForm Frm, X
Sleep 5
DoEvents
Next X
Else
For X = 0 To 255 Step 15
TranslucentForm Frm, X
Sleep 5
DoEvents
Next X
End If
Frm.Enabled = True
End Sub
Public Sub TranslucentForm(Frm As Form, TranslucenceLevel As Integer)
SetWindowLong Frm.hwnd, GWL_EXSTYLE, WS_EX_LAYERED
SetLayeredWindowAttributes Frm.hwnd, 0, TranslucenceLevel, LWA_ALPHA
End Sub
Re: flicker on fading form
Quote:
Originally Posted by Edgemeal
Try calling the translucent API routine on form load, that's what seems to fixed it for me, without doing that I had same flicker problem. Here's basically what I been using....
Code:
Option Explicit
Private Sub Form_Load()
TranslucentForm Me, 0 ' make me transparent ' 255 = solid
Me.Show
DoEvents
DoFade Me, True ' fade in
End Sub
Private Sub Command2_Click()
' fade out
DoFade Me, False
End Sub
Code:
Option Explicit
' Translucent
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) _
As Long
Private Declare Function SetLayeredWindowAttributes Lib _
"user32" (ByVal hwnd As Long, ByVal crKey As Long, _
ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
'Zzzzzz___
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DoFade(Frm As Form, FadeIn As Boolean)
' // Fade form in or out //
Dim X As Integer
Frm.Enabled = False
If FadeIn = False Then
For X = 145 To 0 Step -5
TranslucentForm Frm, X
Sleep 5
DoEvents
Next X
Else
For X = 0 To 255 Step 15
TranslucentForm Frm, X
Sleep 5
DoEvents
Next X
End If
Frm.Enabled = True
End Sub
Public Sub TranslucentForm(Frm As Form, TranslucenceLevel As Integer)
SetWindowLong Frm.hwnd, GWL_EXSTYLE, WS_EX_LAYERED
SetLayeredWindowAttributes Frm.hwnd, 0, TranslucenceLevel, LWA_ALPHA
End Sub
Thanks, that works better than mine
