Full Version: Runtime Error On Fade Form
UtterAccess Forums > Microsoft® Access > Access Forms
kalove
I am getting the followng error dialog within the "on open":
Runtime Error detected. Error in Module frmSplashScreen1. Procedure Form_Open. Error 438 Error description object does'nt support this property method. However, if I select the OK button from the error dialog box the fade out works on the splash screen. Here is my vb behind my on open, timer and close from the frmSplashScreen1: (Timer interval set at 5000)
----------------------------------------------------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Private Const conSaturation As Long = 255
Private Sub Form_Close()
If (conHandleErrors) Then On Error GoTo ErrorHandler
FadeInOut Me.Name, conSaturation, "Out"
DoCmd.OpenForm "frmNavigation"

ExitProcedure:
Exit Sub
ErrorHandler:
DisplayError "Form_Close", Me.Name
Resume ExitProcedure

End Sub
Private Sub Form_Open(ByRef intCancel As Integer)
If (conHandleErrors) Then On Error GoTo ErrorHandler
ShadowLabel Me.lblTitle, Me.lblTitleShadow, conTitle

ExitProcedure:
Exit Sub
ErrorHandler:
DisplayError "Form_Open", Me.Name
Resume ExitProcedure
End Sub
-------------------------------------------------------------------------------------------------------
Private Sub Form_Timer()

If (conHandleErrors) Then On Error GoTo ErrorHandler

Me.TimerInterval = 0

FadeInOut Me.Name, conSaturation, "Out"
DoCmd.OpenForm "frmNavigation"
ExitProcedure:
On Error Resume Next
DoCmd.Close acForm, Me.Name
Exit Sub
ErrorHandler:
DisplayError "Form_Timer", Me.Name
Resume ExitProcedure
End Sub
=================================================================
THere is the fade module code:
Option Explicit
Option Compare Text
Private Const conModuleName As String = "mdlFadeForm"
'KPD-Team 2000
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
'But somewhat modified by me.
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
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 SetWindowOpacity Lib "user32" _
Alias "SetLayeredWindowAttributes" (ByVal hWnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Private Const conFadeForm As Boolean = True
Public Const conFadeSleep As Long = 10
Public Const conOpacityStep As Long = 5
Public blnFadingInProgress As Boolean
Public Sub FadeInOut(ByVal strFormName As String, _
ByVal lngSaturation As Long, _
ByVal strInOut As String)

Dim lngOpacity As Long

If (conHandleErrors) Then On Error GoTo ErrorHandler

blnFadingInProgress = True

If (conFadeForm) Then
If FormIsLoaded(strFormName) Then
Select Case strInOut
Case "In"
For lngOpacity = 0 To lngSaturation Step conOpacityStep
FadeForm Forms(strFormName).hWnd, lngOpacity
Sleep conFadeSleep
DoEvents
Next lngOpacity

Case "Out"
For lngOpacity = lngSaturation To 0 Step -conOpacityStep
FadeForm Forms(strFormName).hWnd, lngOpacity
Sleep conFadeSleep
DoEvents
Next lngOpacity

End Select
End If
End If
ExitProcedure:
On Error Resume Next
blnFadingInProgress = False
Exit Sub
ErrorHandler:
DisplayError "FadeInOut", conModuleName
Resume ExitProcedure
End Sub
Public Sub FadeForm(ByRef lhWnd As Long, _
ByVal bytOpacity As Byte)
Dim lngReturn As Long

If (conHandleErrors) Then On Error GoTo ErrorHandler

If (conFadeForm) Then
'Set the window style to 'Layered'
lngReturn = GetWindowLong(lhWnd, GWL_EXSTYLE)
lngReturn = lngReturn Or WS_EX_LAYERED
SetWindowLong lhWnd, GWL_EXSTYLE, lngReturn

'Set the opacity of the layered window.
SetWindowOpacity lhWnd, 0, bytOpacity, LWA_ALPHA
End If

ExitProcedure:
Exit Sub
ErrorHandler:
DisplayError "FadeForm", conModuleName
Resume ExitProcedure

End Sub
Public Function FormIsLoaded(ByVal strFormName As String) As Boolean

If (conHandleErrors) Then On Error GoTo ErrorHandler

If (SysCmd(acSysCmdGetObjectState, acForm, strFormName)) Then
If (Forms(strFormName).CurrentView) Then
FormIsLoaded = True
End If
End If

ExitProcedure:
Exit Function
ErrorHandler:
DisplayError "FormIsLoaded", conModuleName
Resume ExitProcedure

End Function
Public Sub TransferFromTo(ByVal strFromFormName As String, _
ByVal strToFormName As String, _
Optional ByVal vntXOffset As Variant, _
Optional ByVal vntYOffset As Variant)

Dim lngOpacity As Long

If (conHandleErrors) Then On Error GoTo ErrorHandler

blnFadingInProgress = True

DoCmd.OpenForm strToFormName, , , , , , strFromFormName
Forms(strToFormName).TimerInterval = 0

If Not IsMissing(vntXOffset) Then
DoCmd.MoveSize vntXOffset
End If

If Not IsMissing(vntYOffset) Then
DoCmd.MoveSize , vntYOffset
End If

If (conFadeForm) Then
For lngOpacity = 0 To 255 Step 5
FadeForm Forms(strFromFormName).hWnd, 255 - lngOpacity
FadeForm Forms(strToFormName).hWnd, lngOpacity
Sleep conFadeSleep
DoEvents
Next lngOpacity
End If

ExitProcedure:
On Error Resume Next
blnFadingInProgress = False
Forms(strFromFormName).OnUnload = ""
DoCmd.Close acForm, strFromFormName
Exit Sub
ErrorHandler:
DisplayError "TransferFromTo", conModuleName
Resume ExitProcedure

End Sub
====================================================================
====================================================================
Oalso have an error handling module:
Option Explicit
Option Compare Text
Private Const conModuleName As String = "mdlHandleErrors"
Public Const conHandleErrors As Boolean = True
Public Sub DisplayError(ByVal strProcedureName As String, _
ByVal strModuleName As String, _
Optional ByVal strAdditionalInfo As String = "")
Dim strMessage As String

strMessage = "Error in Module: " & strModuleName & vbNewLine & _
"Procedure: " & strProcedureName & vbNewLine & vbNewLine & _
"Error Number: " & Err.Number & vbNewLine & _
"Error Description: " & Err.Description
If (conHandleErrors) Then On Error GoTo ErrorHandler
If strAdditionalInfo <> "" Then
strMessage = strMessage & vbNewLine & vbNewLine & _
"Additional Information:" & vbNewLine & _
strAdditionalInfo
End If

MsgBox strMessage, vbCritical, "Runtime error detected"

ExitProcedure:
Screen.MousePointer = 0
Exit Sub
ErrorHandler:
MsgBox "Error in Module: " & conModuleName & vbNewLine & _
"Procedure: DisplayError" & vbNewLine & vbNewLine & _
"Error Number: " & Err.Number & vbNewLine & _
"Error Description: " & Err.Description

Resume ExitProcedure

End Sub
ChrisO
G’day kalove.
ithout seeing the actual application I can only think that the error is being raised on the line: -
ShadowLabel Me.lblTitle, Me.lblTitleShadow, conTitle
I did you change Me.lblShadow to Me.lblTitleShadow?
If that doesn’t help, can you please post a sample database. (Please remove any sensitive info.)
Regards,
Chris.
kalove
Here is a sample attachment. Thanks for your help.
ChrisO
The third argument to subroutine ShadowLabel needs to be a string, you are trying to pass a Label...conTitle.
Try changing the line to: -
ShadowLabel Me.lblTitle, Me.lblTitleShadow, Me.conTitle.Caption
Hope that helps.
Regards,
Chris.
kalove
That did it. Thanks
This is a "lo-fi" version of UA. To view the full version with more information, formatting and images, please click here.