DEVelopers HUT

'---------------------------------------------------------------------------------------
' Procedure : ajustPercentage
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Automatically adjust whole number to percentage values
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Sep-21                 Initial Release
'---------------------------------------------------------------------------------------
Function ajustPercentage(sValue As Variant) As Double
On Error GoTo Error_Handler
 
    If IsNumeric(sValue) = True Then            'Only treat numeric values
        If Right(sValue, 1) = "%" Then
            sValue = Left(sValue, Len(sValue) - 1)
            ajustPercentage = CDbl(sValue)
        End If
 
        If sValue > 1 Then
            sValue = sValue / 100
            ajustPercentage = sValue
        Else
            ajustPercentage = sValue
        End If
    Else                                        'Data passed is not of numeric type
        ajustPercentage = 0
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ajustPercentage" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Private Sub YourCboName_NotInList(NewData As String, Response As Integer)
'Requires that a reference to the Microsoft DAO 3.6 Object Library
On Error GoTo Error_Handler
    Dim rst As DAO.Recordset
 
    If MsgBox(NewData & "... not in list, add it?", vbOKCancel, "MessageBoxTitle") = vbOK Then
        Set rst = CurrentDb.OpenRecordset("TableName") 'Table to add the new value to
        With rst
            .AddNew
            .Fields("TableColumnName") = NewData 'Name of the table field to add the new value to
            .Update
        End With
        Response = acDataErrAdded
    Else
        Response = acDataErrContinue
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Sub
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: YourCboName_NotInList" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

'---------------------------------------------------------------------------------------
' Procedure : IsFrmOpen
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine whether a form is open or not
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFrmName  : Name of the form to check if it is open or not
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' IsFrmOpen("Form1")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-May-26                 Initial Release
'---------------------------------------------------------------------------------------
Function IsFrmOpen(sFrmName As String) As Boolean
On Error GoTo Error_Handler
 
    If Application.CurrentProject.AllForms(sFrmName).IsLoaded = True Then
        IsFrmOpen = True
    Else
        IsFrmOpen = False
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: IsFrmOpen" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : CountOpenFrms
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Returns a count of the number of loaded Forms (preview or design)
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites.
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Oct-30                 Initial Release
'---------------------------------------------------------------------------------------
Function CountOpenFrms()
On Error GoTo Error_Handler
 
    CountOpenFrms = Application.Forms.Count
 
Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: CountOpenFrms" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
End Function

'---------------------------------------------------------------------------------------
' Procedure : ListOpenFrms
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Returns a list of all the loaded forms (preview or design)
'             separated by ; (ie: Form1;Form2;Form3)
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites.
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function ListOpenFrms()
On Error GoTo Error_Handler
 
    Dim DbF     As Form
    Dim DbO     As Object
    Dim Frms   As Variant
 
    Set DbO = Application.Forms 'Collection of all the open forms
    
    For Each DbF In DbO    'Loop all the forms
            Frms = Frms & ";" & DbF.Name
    Next DbF
 
    If Len(Frms) > 0 Then
        Frms = Right(Frms, Len(Frms) - 1)   'Truncate initial ;
    End If
 
    ListOpenFrms = Frms
 
Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: ListOpenFrms" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
End Function