Add additional codes in the VBA so that it fades in more than 1 userform.

danbates

Active Member
Joined
Oct 8, 2017
Messages
377
Office Version
  1. 2016
Platform
  1. Windows
Hi,

I have copied this code from the internet and it fades in my UserForm1 when called.

Form Fader:
Code:
Option Explicit[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
   Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
           (ByVal hWnd As LongPtr, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long


   Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
           (ByVal hWnd As LongPtr, ByVal lngWinIdx As Long) As Long


   Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
           (ByVal hWnd As LongPtr, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
   Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
   Dim hWnd                        As LongPtr


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
   Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
                                          (ByVal hWnd As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long


   Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
                                          (ByVal hWnd As Long, ByVal lngWinIdx As Long) As Long


   Private Declare Function SetLayeredWindowAttributes Lib "user32" _
                                                       (ByVal hWnd As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long


   Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
   Dim hWnd                        As Long


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = &HFFEC
Public Sub Fade(ByVal lStep As Long, Optional ByVal lStart As Long = 0, Optional ByVal lStop As Long = 100)
   Dim lTemp As Long
   Dim lCounter As Long
   
   lCounter = (lStop - lStart) \ lStep
   
   If lCounter * lStep < lStart - lStop Then lCounter = lCounter + 1
   
   For lTemp = 1 To lCounter
      DoEvents
      Sleep 20
      Call SemiTransparent(lStart + lTemp * lStep)
      DoEvents
   Next lTemp
End Sub
Public Sub SemiTransparent(ByVal intLevel As Integer)
   Dim lngWinIdx                   As Long
   lngWinIdx = GetWindowLong(hWnd, GWL_EXSTYLE)
   SetWindowLong hWnd, GWL_EXSTYLE, lngWinIdx Or WS_EX_LAYERED
   SetLayeredWindowAttributes hWnd, 0, 255 * (intLevel / 100), LWA_ALPHA
End Sub
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Public Property Get FormWindowHandle() As LongPtr


   FormWindowHandle = hWnd


End Property


Public Property Let FormWindowHandle(ByVal lFormWindowHandle As LongPtr)


   hWnd = lFormWindowHandle


End Property
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 


Public Property Get FormWindowHandle() As Long


   FormWindowHandle = m_hWnd


End Property


Public Property Let FormWindowHandle(ByVal lFormWindowHandle As Long)


   m_hWnd = lFormWindowHandle


End Property
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

BackgroundTest userform
Code:
Option Explicit
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
   Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
   (ByVal hWnd As LongPtr, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
    
   Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hWnd As LongPtr, ByVal lngWinIdx As Long) As Long
    
   Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
   Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
   Dim hWnd As LongPtr


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
   Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
   (ByVal hWnd As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
    
   Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hWnd As Long, ByVal lngWinIdx As Long) As Long
    
   Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
   Dim hWnd As Long


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Dim Running As Boolean
Dim oFader As FormFader


Private Sub UserForm_Initialize()
   
 Dim Style As Long
 
 hWnd = FindWindow(vbNullString, Me.Caption)
 Set oFader = New FormFader
 oFader.FormWindowHandle = hWnd
 Style = GetWindowLong(hWnd, -16) And Not &HC00000
 SetWindowLong hWnd, -16, Style
 DrawMenuBar hWnd
 oFader.SemiTransparent 0
End Sub
 
Private Sub UserForm_activate()
   If Running Then Exit Sub
With Me
        .Height = Application.Height
        .Width = Application.Width
        .Left = Application.Left
        .Top = Application.Top
    End With
    
   Running = True
   oFader.Fade 5, 0, 60
   
   Call ShowSecondForm
   Unload Me
      
End Sub
Private Sub Userform_QueryClose(Cancel As Integer, closemode As Integer)
   oFader.Fade -5, 60, 0
End Sub


Sub ShowSecondForm()
UserForm1.Show
End Sub

What I would like is to amend it so it fades in the following userforms as well:
NewProduct
Password
Search

Hope this all makes sense.

Kind Regards

Dan
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Forum statistics

Threads
1,224,814
Messages
6,181,124
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top