Userform FadeIn/FadeOut Ivan F Moala, read in please

[merlin_the_magician]

Ivan,

first of all i have to thank you for sending me an example workbook on fading userforms. It's lovely, exactly what i meant.
I have been playing with it a little, but i think i will need a lity little bit of help.
I cut parts of you code, and pasted them together like the code underneath. It seems to be working fine at first, but then it somehow gets stuck on the last piece of the code, Private Function MakeTransparent(lIndex As Long) As Long what is wrong?


Private Sub UserForm_Activate()
'// Main routine to FadeIn/FadeOut
Application.Wait (Now + TimeValue("0:00:03"))
Call FadeOut(256 * 4)
Image1.Visible = False
Me.BackColor = &H8000000F
Call FadeIn(256 * 4)
Application.Wait (Now + TimeValue("0:00:06"))
Unload Me
End Sub



' MODIFIED: Ivan F Moala 2/6/2002
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'// Leave this here as your backdoor, incase you have NO CLOSE BUTTON
Unload Me
End Sub

''//
Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT

'// Get the window's position:
GetWindowRect lFrmHdl, tR

'// Modify whether title bar will be visible:
lStyle = GetWindowLong(lFrmHdl, GWL_STYLE)
'
If Not bState Then
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
blnTitleVisible = True
Else
lStyle = lStyle Or WS_SYSMENU
lStyle = lStyle Or WS_MAXIMIZEBOX
lStyle = lStyle Or WS_MINIMIZEBOX
lStyle = lStyle Or WS_CAPTION
blnTitleVisible = False
End If

SetWindowLong lFrmHdl, GWL_STYLE, lStyle

'// Ensure the style takes and make the window the
'// same size, regardless that the title bar
'// is now a different size:
SetWindowPos lFrmHdl, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, _
SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
Me.Repaint

End Function

Private Sub FadeIn(Fin As Long)
Dim X As Long

MakeTransparent 0

X = 0
Do Until X = Fin
DoEvents
X = X + 1
MakeTransparent X / 2
Loop

End Sub

Private Function FadeOut(Fin As Long)
Dim Y As Long

Call MakeTransparent(255)

Y = Fin '1000

Do Until Y = 0
DoEvents
Y = Y - 1
Call MakeTransparent(Y / 2)
Loop

End Function

Private Function MakeTransparent(lIndex As Long) As Long

End Function

On Error Resume Next
If lIndex < 0 Or lIndex > 255 Then
MakeTransparent = 0 '1
Else
lResult = GetWindowLong(lFrmHdl, GWL_EXSTYLE)
lResult = lResult Or WS_EX_LAYERED
SetWindowLong lFrmHdl, GWL_EXSTYLE, lResult
SetLayeredWindowAttributes lFrmHdl, 0, lIndex, LWA_ALPHA
MakeTransparent = 0
End If

If Err Then MakeTransparent = 2

End Function

[Andrew Poulsom]

Try removing the superfluous End Function which appears immediately after Private Function MakeTransparent(lIndex As Long) As Long.

[merlin_the_magician]

Obvious...

But not quite the solution because it hangs on GetWindowLong and SetWindowLong now. What else could be buggy?

[Andrew Poulsom]

Where have you declared those functions? Should be at the top of your module:

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

[Ivan F Moala]

You need all the routines

But 1st off you need this in the Userform code

Private Sub UserForm_Initialize()
    '// Ivan F Moala
    lFrmHdl = FindWindowA(vbNullString, Me.Caption)
    ShowTitleBar False
    '// Need this call 1st to set > No Flicker
    MakeTransparent (255)
End Sub

Then you need to Export to you current code the API Routines

This is the Module basAPI which should look like this;

Option Explicit

'// Transparency
Public Declare Function SetLayeredWindowAttributes _
    Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal crKey As Long, _
    ByVal bAlpha As Byte, _
    ByVal dwFlags As Long) _
As Long

'//
Public Declare Function GetWindowRect Lib "user32" ( _
   ByVal hWnd As Long, _
   lpRect As RECT) 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 GetWindowLong Lib "user32" _
   Alias "GetWindowLongA" ( _
   ByVal hWnd As Long, _
   ByVal nIndex As Long) As Long
   
'// Win Styles
Public Const GWL_EXSTYLE = (-20)
Public Const GWL_STYLE = (-16)

Public Const WS_EX_LAYERED = &H80000
Public Const WS_CAPTION = &HC00000            ' WS_BORDER Or WS_DLGFRAME
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_SYSMENU = &H80000

'//
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2
Public Const ULW_COLORKEY = &H1
Public Const ULW_ALPHA = &H2
Public Const ULW_OPAQUE = &H4

'// Used for moving Captionless form
Public Declare Function SetWindowPos Lib "user32" ( _
   ByVal hWnd As Long, _
   ByVal hWndInsertAfter As Long, _
   ByVal X As Long, _
   ByVal Y As Long, _
   ByVal cx As Long, _
   ByVal cy As Long, _
   ByVal wFlags As Long) As Long

Public Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" ( _
   ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long

 
Public Declare Function FindWindowA _
    Lib "user32" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
As Long
  
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOOWNERZORDER = &H200    ' Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Public Const HWND_NOTOPMOST = -2

Public Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Public lResult As Long
Public frmHdl As Long
Public blnTitleVisible As Boolean
Public blnCtrlShow As Boolean

Public lFrmHdl  As Long

[merlin_the_magician]

Eh... i'm confused... Ivan, i emailed you my workbook. Would you mind having a breef look at it to see what's wrong please?

[Ivan F Moala]

This will cost you lol

[merlin_the_magician]

Don't think i can find the time to bring something by, it quite a long trip you know

Sending it by pigeon is probably no option eighter

[Ivan F Moala]

Send by all means ......

[merlin_the_magician]

Ivan.... i think i love you

This is great!!! Thank you so very much!

One minor thing: there is an piece of code that will prevent flickering of the userform on startup. I still can see a flicker however. Can this be fixed?

Private Sub UserForm_Initialize()
'// Ivan F Moala
lFrmHdl = FindWindowA(vbNullString, Me.Caption)
ShowTitleBar False
'// Need this call 1st to set > No Flicker
MakeTransparent (255)
End Sub