Ms Access fade in form with Windows API - ms-access

I've managed to make my form fade out correctly, but for some reason my fade in isn't working correctly. The form "hitches" during the load. It loads normally, and then fades in. Rather than just fading in the begin with.
It's done by creating a module, and then code within the form.
The form code:
Option Compare Database
Dim gintC
Private Sub Form_Load()
Me.TimerInterval = 2
FadeForm Me, Fadezero, 1, 5
End Sub
Private Sub Form_Timer()
If IsEmpty(gintC) Then
FadeForm Me, Fadein, 1, 15
End If
gintC = 1
Me.TimerInterval = 0
End Sub
Private Sub Form_Close()
FadeForm Me, Fadeout, 1, 255
End Sub
The module:
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&
'Enum for determining the direction of the fade.
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)
Dim lOriginalStyle As Long
Dim iCtr As Integer
'You can only set a form's opacity if it's Popup property = True.
If (frm.PopUp = True) Then
'Get the form window’s handle, and remember its original style.
lOriginalStyle = GetWindowLong(frm.hWnd, GWL_EXSTYLE)
SetWindowLong frm.hWnd, GWL_EXSTYLE, lOriginalStyle Or WS_EX_LAYERED
'If the form’s original style = 0, it hasn’t been faded since it was opened.
'To get fading to work, we have to set its style to something other than zero.
If (lOriginalStyle = 0) And (Direction <> FadeDirection.SetOpacity) Then
'Recursively call this same procedure to set the value.
FadeForm frm, SetOpacity, , StartOpacity
End If
'Depending on the direction of the fade...
Select Case Direction
Case FadeDirection.Fadezero
iCtr = StartOpacity
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
Case FadeDirection.Fadein
'Just in case.
If StartOpacity < 1 Then StartOpacity = 1
'Fade the form in by varying its opacity
'from the value supplied in 'StartOpacity'
'to 255 (completely opaque).
For iCtr = StartOpacity To 255 Step 1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case FadeDirection.Fadeout
'Just in case.
If StartOpacity < 6 Then StartOpacity = 255
'Fade the form out by varying its opacity
'from 255 to 1 (almost transparent).
For iCtr = StartOpacity To 1 Step -1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case Else 'FadeDirection.SetOpacity.
'Just in case.
Select Case StartOpacity
Case Is < 1: StartOpacity = 1
Case Is > 255: StartOpacity = 255
End Select
'Set the form's opacity to a specific value.
SetLayeredWindowAttributes frm.hWnd, 0, CByte(StartOpacity), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
End Select
Else
'The form’s Popup property MUST = True
DoCmd.Beep
MsgBox "The form's Popup property must be set to True.", vbOKOnly & vbInformation, "Cannot fade form"
End If
End Sub
Any Advice? Any idea why the closing fade works, but the loading fade doesn't?
Thanks.

You should
move code from Load to Open event
call OpenForm with WindowMode = acHidden
set Me.Visible = True in Timer

Related

How to make the process run while the button is pressed?

I use:
  - Win 7x64;
  - Access - 2016;
I try to solve my problem with the following code.
Form1
Option Compare Database
Option Explicit
Public statusBool As Boolean
Public numProc As Integer
' `Button pressed`.
Private Sub btnStart_Click()
numProc = 0
statusBool = True
Call Process(statusBool, numProc)
End Sub
' Process
Public Sub Process(statusBool As Boolean, numProc As Integer)
If statusBool = True Then
Me.txtProcessFrm = "ProcessNum - " & numProc + 1
Call SleepFor(1000) '1 seconds delay
Call Process(statusBool, numProc)
End If
End Sub
'
Private Sub btnStart_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = False
numProc = 0
Call Process(statusBool, numProc)
End Sub
Public Sub SleepFor(ByVal MilliSeconds As Long)
Sleep MilliSeconds
End Sub
Module1
Option Compare Database
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Question
Will my solution be correct for this task or are there simpler ways to solve this problem?
Update_1
The code does not start.
I get an error Sub or Function not defined.
Update_2
Module Module1.
Replaced Private to Public.
It was
 Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
It became
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Problem.
When I click the button btnStart_Click the file hangs
Update_3
Modified Process (statusBool As Boolean, numProc As Integer)
It became.
' Process
Public Sub Process(statusBool As Boolean, numProc As Integer)
If statusBool = True Then
Do
Sleep 1000
DoEvents
Loop Until Me.txtProcessFrm = "ProcessNum - " & numProc + 1
Call Process(statusBool, numProc)
End If
End Sub
Problem.
It seems the pause works, but the logic itself does not work.
In other words, the text field is not filled with text.
If you release the button, the cycle continues to work.
The chain of event for clicking a button follows as this.
MouseDown → MouseUp → Click → DblClick → Click
In your code, the loop will never stop because your statusBool will always be true causing infinite loop and that's probably why it's hanging even if you release the mosue.
you can however try this mouse down => mouse up:
Private Sub btnStart_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = True
Call Process(0)
End Sub
Private Sub btnStart_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
statusBool = False
End Sub
Public Sub Process(numProc As Integer)
If statusBool Then
numProc = numProc + 1
Me.txtProcessFrm = "ProcessNum - " & numProc
Sleep 1000
DoEvents
Call Process(numProc)
End If
End Sub
more here:
https://learn.microsoft.com/en-us/office/vba/api/access.commandbutton.click

Download File from IE11 + Create a folder to store it

I had lots of issues dealing with that IE 11 download bar when downloading a file.
I checked different solutions but the only way to make it work the most reliably possible was to put two of them together.
Then I set the default internet download folder as my Desktop so that whenever I download a file with SendKeys I know where to find it with the code.
For the little story, my code is downloading the attached files for all the different incident cases. The number/type of attachments can vary and to oragnize it a little bit I decided to create a folder with the name of the incident case and store the attachments inside.
So here is my code, if you see a part which could be improved let me know :)
Option Explicit
Private objIE As SHDocVw.InternetExplorer
Private ContentFrame As HTMLIFrame
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub LeftClick()
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Sub DownloadAttachment()
'make sure Cell A4 isn't empty because it has to contain the incident case
If Sheets(1).Cells(4, 1) = "" Or Sheets(1).Cells(4, 1) = " " Then End
'make sure it's a valid case No. before going on
On Error GoTo Fin
If Len(Cells(4, 1)) <> 8 Or CLng(Sheets(1).Cells(4, 1)) = 0 Then
MsgBox "Please enter a valid Case No."
End
End If
Call GetDataFromIntranet(Sheets(1).Cells(4, 1)
'Delete content on cell A4
Fin:
Sheets(1).Cells(4, 1) = ""
End Sub
Function GetDataFromIntranet(CaseNo As Long)
Dim i As Integer
If ("attachmentDivId").Children(0).Children(1).Children.Length >= 1 Then Call CreateFolder(CaseNo) ' If there is at least 1 attachment then we'll create a folder which has the name of the incident case
For i = 0 To objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children.Length - 1 ' For each attachment...
RetourALaCaseDepart:
objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Click ' Click on it so that it gets activated (blue)
objIE.document.frames(1).frames(1).document.getElementsByName("download")(0).Click 'Click on Save as
'The following bit send keyboard keys to cope with the Internet Downaload window that appears down the page -> downloads the file and save it on the Desktop
Application.Wait Now + TimeSerial(0, 0, 10)
Application.SendKeys "%{S}"
Application.Wait Now + TimeSerial(0, 0, 10)
SendKeys "{F6}", True
SendKeys "{TAB}", True
SendKeys "{ENTER}", True
'Here we close the Desktop window which sometimes open because it can alter the SendKey codes which is very sensitive
Dim objShellWindows As New SHDocVw.ShellWindows
Dim win As Object
For Each win In objShellWindows
If win.LocationName = "Desktop" Then
win.Quit
End If
Next win
Application.Wait Now + TimeSerial(0, 0, 1)
If MakeSureDownloaded(objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Children(0).innerText, CaseNo) = False Then GoTo RetourALaCaseDepart ' We check if the attachment was successfully saved, if not we redo the saving process from "RetourALaCaseDepart
Next i
Exit Function
Fini:
MsgBox "No attachments found or attachment tab not found"
End Function
Function MakeSureDownloaded(FileName As String, CaseNo As Long) As Boolean
Dim FileSys As Object 'FileSystemObject
Dim objFile As Object 'File
Dim myFolder
Dim strFilename As String
Const myDir As String = "C:\Users\Seb\Desktop\"
'set up filesys objects
Set FileSys = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
For Each objFile In myFolder.Files
If objFile.Name Like FileName & "*" Then ' If the file was saved then we will add it to the folder created earlier for that Case
strFilename = objFile.Name
MakeSureDownloaded = True
GoTo BienBien
End If
Next objFile
MakeSureDownloaded = False
Set FileSys = Nothing
Set myFolder = Nothing
Exit Function
BienBien:
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Call fso.MoveFile("C:\Users\Seb\Desktop\" & strFilename, "Path...\Case_Attachments\" & CaseNo & "\" & strFilename)
Set FileSys = Nothing
Set myFolder = Nothing
End Function
Sub CreateFolder(CaseNo As Long)
Dim fsoFSO
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists("Path...\Case_Attachments\" & CaseNo) Then ' do nothing actually...
Else
fsoFSO.CreateFolder ("Path...\Case_Attachments\" & CaseNo)
End If
End Sub

VBA editor events

I have some controls in MS Access form that change the system language to Turkish, Arabic and English and I want to change the system language to English when I go to VBA to write some code.
I have a code that change system language and want to know
How to run this code automatically when I activate VBA editor?
If you put the following code on start of your application, it would run automatically Test2, whenever you press Alt+F11.
Private Sub Workbook_Open()
Application.OnKey "%{F11}", "Test2"
End Sub
Public Sub Test2()
Debug.Print "tested"
End Sub
I am not sure whether this is exactly what you want, but it is a work around to achieve it.
Edit:
Actually, here you may find plenty of useful stuff:
http://www.mrexcel.com/forum/excel-questions/468063-determine-language-user.html
E.g. With the Sub ShowLanguages you may built a function telling you which language are you using and if it is not English, you may switch to it, the way you do it in your answer. I would probably built something similar later.
Private Const LOCALE_ILANGUAGE As Long = &H1
Private Const LOCALE_SCOUNTRY As Long = &H6
Private Declare Function GetKeyboardLayout Lib "user32" _
(ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" _
Alias "GetLocaleInfoA" _
(ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long
Public Sub ShowLangauges()
Dim hKeyboardID As Long
Dim LCID As Long
hKeyboardID = GetKeyboardLayout(0&)
If hKeyboardID > 0 Then
LCID = LoWord(hKeyboardID)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_ILANGUAGE)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_SCOUNTRY)
End If
End Sub
Private Function LoWord(wParam As Long) As Integer
If wParam And &H8000& Then
LoWord = &H8000& Or (wParam And &H7FFF&)
Else
LoWord = wParam And &HFFFF&
End If
End Function
Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, _
ByVal dwLCType As Long) As String
Dim sReturn As String
Dim nSize As Long
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
sReturn = Space$(nSize)
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
GetUserLocaleInfo = Left$(sReturn, nSize - 1)
End If
End If
End Function
I use Timer to check if VBA editor window is the active window every 0.5 Sec and if true I run my function that change the language to English and stop Timer:
Private Sub Form_Timer()
Dim st As String
On Error Resume Next
st = VBE.ActiveWindow.Caption
If Err = 0 Then
ChLng 1033
Me.TimerInterval = 0
End If
On Error GoTo 0
End Sub
And I run Timer again when any control on my form change the language to non English language:
Private Sub cmbAR_GotFocus()
ChLng 1025
Me.TimerInterval = 500
End Sub
Private Sub cmbTR_GotFocus()
ChLng 1055
Me.TimerInterval = 500
End Sub
In Form design I manually add all needed events including Form Load event that run the Timer:
Private Sub Form_Load()
Me.TimerInterval = 500
End Sub
NOTE: ChLng xxxx is the function that change the language:
(Find your desired language at BCP 47 Code)
Private Declare Function ActivateKeyboardLayout Lib _
"user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long
'define your desired keyboardlanguage
Sub ChLng(lng As Long)
ActivateKeyboardLayout lng, 0
End Sub

MS Access 2013 to show only startup form and nothing else

While starting up my MS Access 2013 database, I only need it to show the startup form and nothing else. Desired result would be something like below. The background is my desktop.
Desired:
However when I open the DB, the form opens taking the entire screen.
The below VBA code runs when the startup form loads and initially it works, but if I minimize the window I can see the background again.
Option Compare Database
Option Explicit
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Global Const SW_SHOWMAXIMIZED = 3
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Function fSetAccessWindow(nCmdShow As Long)
Dim loX As Long
Dim loForm As Form
On Error Resume Next
Set loForm = Screen.ActiveForm
If Err <> 0 Then
loX = apiShowWindow(hWndAccessApp, nCmdShow)
Err.Clear
End If
If nCmdShow = SW_SHOWMINIMIZED And loForm.Modal = True Then
MsgBox "Cannot minimize Access with " _
& (loForm.Caption + " ") _
& "form on screen"
ElseIf nCmdShow = SW_HIDE And loForm.PopUp <> True Then
MsgBox "Cannot hide Access with " _
& (loForm.Caption + " ") _
& "form on screen"
Else
loX = apiShowWindow(hWndAccessApp, nCmdShow)
End If
fSetAccessWindow = (loX <> 0)
End Function
I have hidden ribbons, navigation pane and all access user interfaces, but I need to remove the Access background also.
Current:
Any help / advice would be appreciated. Thanks in advace !!!
You don’t need any API code.
The following settings should do the trick:
File->Options->Current Database
Uncheck “Display document tabs”
Choose Tabbed Documents.
In above also un-check Display navigation Pane.
To hide the ribbon, execute this ONE line of VBA in your startup:
DoCmd.ShowToolbar "Ribbon", acToolbarNo
The resulting screen will be this:
Make sure the form(s) are not dialog, and make sure they are not popup forms.
To go back into “development” mode, you exit the database and then re-launch holding down the shift key – that will by-pass all of the above and allow you to develop.
I use synchronization of main form and Access windows sizes, so Access window will be always behind main window. Here is code behind:
Private Sub Form_Resize()
'main form
'Let us know when Form is Maximized...
If CBool(IsZoomed(Me.hwnd)) = True Then
funSetAccessWindow (SW_SHOWMAXIMIZED)
DoCmd.Maximize
Me.TimerInterval = 0
ElseIf CBool(IsIconic(Me.hwnd)) = True Then
funSetAccessWindow (SW_SHOWMINIMIZED)
Me.TimerInterval = 0
Else
'enable constant size sync
Me.TimerInterval = 100
SyncMainWindowSize Me, True
End If
End Sub
Private Sub Form_Timer()
SyncMainWindowSize Me
End Sub
Public Function SyncMainWindowSize(frm As Form, Optional blnForce As Boolean = False)
Dim rctForm As RECT
Dim iRtn As Integer
Dim blnMoved As Boolean
Static x As Integer
Static y As Integer
Static cx As Integer
Static cy As Integer
#If VBA7 And Win64 Then
Dim hWndAccess As LongPtr
#Else
Dim hWndAccess As Long
#End If
If GetWindowRect(frm.hwnd, rctForm) Then
If x <> rctForm.Left Then
x = rctForm.Left
blnMoved = True
End If
If y <> rctForm.Top Then
y = rctForm.Top
blnMoved = True
End If
If cx <> rctForm.Right - rctForm.Left Then
cx = rctForm.Right - rctForm.Left
blnMoved = True
End If
If cy <> rctForm.Bottom - rctForm.Top Then
cy = rctForm.Bottom - rctForm.Top
blnMoved = True
End If
If blnMoved Or blnForce Then
'move/resize main window
hWndAccess = Application.hWndAccessApp
iRtn = apiShowWindow(hWndAccess, WM_SW_RESTORE)
Call SetWindowPos(hWndAccess, 0, x, y, cx, cy, WM_SWP_NOZORDER Or WM_SWP_SHOWWINDOW)
End If
End If
End Function
Function funSetAccessWindow(nCmdShow As Long)
'Usage Examples
'Maximize window:
' ?funSetAccessWindow(SW_SHOWMAXIMIZED)
'Minimize window:
' ?funSetAccessWindow(SW_SHOWMINIMIZED)
'Hide window:
' ?funSetAccessWindow(SW_HIDE)
'Normal window:
' ?funfSetAccessWindow(SW_SHOWNORMAL)
Dim loX As Long
On Error GoTo ErrorHandler
loX = apiShowWindow(hWndAccessApp, nCmdShow)
funSetAccessWindow = (loX <> 0)
End Function

MS Access : Form Timer control...can I use it for setting a time gap in a routine?

Just wondering, if I have some graphical events/animation happening on a splash screen, can I use the timer event some how to simply break up the routine for a small amount of time.
basically like:
-some action events
DoEvents
'some timer interval
-more action code
Use the Windows API to include a pause between code sections. See the sSleep() procedure at this page: Make code go to Sleep
Const clngMilliSeconds As Long = 10000 '(10 seconds) '
'some action events '
DoEvents
'some timer interval '
Call sSleep(clngMilliSeconds)
'more action code '
You could combine a form level variable Dim iStep as integer which will automatically be Static, and in your On Timer proc, something like:
Select Case iStep
Case 1
'do something'
Case 2
'do something else'
Case 3
'etc...'
End Select
iStep = iStep + 1
In this case, I think it would be better to create your own timer by storing Now() to a variable at the start, and checking for the intervals you want with DateDiff, or even straight subtraction, given that dates are stored as numbers.
Form Fade
Dug out of a very old library and not tested recently.
Form:
Option Compare Database
Dim gintC
Private Sub Form_Load()
Me.TimerInterval = 2
FadeForm Me, Fadezero, 1, 5
End Sub
Private Sub Form_Timer()
If IsEmpty(gintC) Then
FadeForm Me, Fadein, 1, 15
End If
gintC = 1
Me.TimerInterval = 0
End Sub
Module:
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&
'Enum for determining the direction of the fade.
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)
Dim lOriginalStyle As Long
Dim iCtr As Integer
'You can only set a form's opacity if it's Popup property = True.
If (frm.PopUp = True) Then
'Get the form window’s handle, and remember its original style.
lOriginalStyle = GetWindowLong(frm.hWnd, GWL_EXSTYLE)
SetWindowLong frm.hWnd, GWL_EXSTYLE, lOriginalStyle Or WS_EX_LAYERED
'If the form’s original style = 0, it hasn’t been faded since it was opened.
'To get fading to work, we have to set its style to something other than zero.
If (lOriginalStyle = 0) And (Direction <> FadeDirection.SetOpacity) Then
'Recursively call this same procedure to set the value.
FadeForm frm, SetOpacity, , StartOpacity
End If
'Depending on the direction of the fade...
Select Case Direction
Case FadeDirection.Fadezero
iCtr = StartOpacity
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
Case FadeDirection.Fadein
'Just in case.
If StartOpacity < 1 Then StartOpacity = 1
'Fade the form in by varying its opacity
'from the value supplied in 'StartOpacity'
'to 255 (completely opaque).
For iCtr = StartOpacity To 255 Step 1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case FadeDirection.Fadeout
'Just in case.
If StartOpacity < 6 Then StartOpacity = 255
'Fade the form out by varying its opacity
'from 255 to 1 (almost transparent).
For iCtr = StartOpacity To 1 Step -1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case Else 'FadeDirection.SetOpacity.
'Just in case.
Select Case StartOpacity
Case Is < 1: StartOpacity = 1
Case Is > 255: StartOpacity = 255
End Select
'Set the form's opacity to a specific value.
SetLayeredWindowAttributes frm.hWnd, 0, CByte(StartOpacity), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
End Select
Else
'The form’s Popup property MUST = True
DoCmd.Beep
MsgBox "The form's Popup property must be set to True.", vbOKOnly & vbInformation, "Cannot fade form"
End If
End Sub