Problem with hiding control setfocus Results

I've got a form, let's call it mainform. On mainform is subform1, on which is subform2, on which is subform3.

Having inputted data on subform3 I want to click on a command button "hide_button" on subform1 which will hide subform3.

I thought initially that clicking on hide_button would also set the focus to the control hide_button but my code

Me.subform2.form!subform3.form.visible=false

...throws up runtime error 2165 "Can't Hide a Control That Has the Focus"

I've tried setting the focus away from the subform to a field on subform1 "field1"...

Me.field1.setfocus
Me.subform2.form!subform3.form.visible=false

but I still get the error.

Any ideas? This one's driving me mad!

Hi all,

I've hit a problem that, based on reading through several forums, many people have had however I'm not having any luck implementing the solutions for my needs!

Basically I've set up two modules within my database - one called User Permissions (to retrieve the level of access the current user should have - run on startup) and then Control Visibility is designed to contain the Sub to hide/disable all relevant controls. The User Permissions module works cleanly and retrieves the name of the group the User belongs to (currently limited to "User", "Reviewer" and "Admin" however there may be another category and I will add some lines to ensure - should a user somehow appear in a new group - that they are treated as "User" as well) - This result is referred to in the following code as UserAccess.

Just to warn you, this code is basically butchered from several sources and put in an order that makes sense to me, but clearly not VBA (I've self-taught VBA to carry out specific tasks so my coding knowledge is probably just past pseudo-code)!



	Code:
	Public Sub Permissions()
Dim ctl As Control
Dim frmName As Form
frmName = Screen.ActiveForm
For Each ctl In frmName.Controls
   'Make all controls invisible and uneditable
        frmName.ctl.Visible = False
        frmName.ctl.Enabled = False
 
        Next ctl
 
If UserAccess = "Admin" Then
    For Each ctl In frmName.Controls
        frmName.ctl.Visible = True
        frmName.ctl.Enabled = True
     Next ctl
 
Else
    For Each ctl In frmName.Controls
 
            'Make User only controls visible, not editable
            If ctl.Tag = Null Then
                frmName.ctl.Visible = True
                frmName.ctl.Enabled = False
              'exit loop if regular user
                If UserAccess = "User" Then
                    Next ctl
                End If
            'Make Reviewer Controls visible and editable where necessary
            ElseIf ctl.Tag = "ReviewVi" Then
                frmName.ctl.Visible = True
                frmName.ctl.Visible = False
            ElseIf ctl.Tag = "ReviewEd" Then
                frmName.ctl.Visible = True
                frmName.ctl.Enabled = True
                'exit loop if reviewer
                If UserAccess = "Reviewer" Then
                    Next ctl
                Else
                End If
            End If
        Next ctl
        Set ctl = Nothing
End If
End Sub

As this code is located in a module to be called up by each form used, it doesn't allow me to use the Me. expression - hence why I'm using Screen.ActiveForm instead (and will add a line to SetFocus when opening a new form!) - this is what's causing me the latest problems - debug currently points at 'frmName = ' (just before Screen.ActiveForm) stating "Invalid use of property". I'm also not entirely sure that 'Next ctl' is the best way to stop the code for a control and move onto the next one. Finally, I'm aware that "ctl.Tag = Null" might be incorrect and might be "" instead, however my code has hit problems before even arriving at that bit so I've not been able to check yet - if you know for sure do let me know!

Also if you see any other problems with this code, please let me know!

Thanks for any and all help. Kind regards,

Michael

Hello,

I have a couple of forms using the code to FIND AS YOU TYPE from Allen Browne (http://allenbrowne.com/AppFindAsUType.html). It worked PERFECTLY until yesterday when i splitted the db into FE/BE. The tables link ok and everything works ok EXCEPT this function. When i open the form it gives me a underlining line (iReturn = ctl.Parent.PageIndex IN THE PARENTNUMBER function in BOLD) and indicating that iReturn=0. I am new with access and i have no idea how to fix this. If i END the debugging the function DOES work, its just that it DOESNT display automtically the name of the first control.

Is there a way to fix this? why is this related with the splitting of the db?? In case there is no real solution how could i just SKIP or "DISREGARD/ACCEPT" the error so that the form open??

Thanks,
Gilberto

the code for the function is:

	Code:
	'Author:      Allen Browne. allen@allenbrowne.com
'Date:        August, 2006.
'Limitations: Combos where the bound column is hidden have these limitations:
'                  -RowSourceType is "Table/Query": filtering supported in Access 2002 or later.
'                  -RowSourceType is "Value List" or a callback function: filtering not supported.

Option Compare Database
Option Explicit

'Configuration options
Private Const mbcStartOfField = False   'True to match only the start of the field; False for anywhere in field.
Private Const mstrcWildcardChar = "*"   'Pattern matching wildcard. "*" for Access. "%" for SQL Server.
Private Const mstrcSep = ";"            'Separator between list items. May need changing for some regional settings.

'Columns of cboFindAsUTypeField
Private Const micControlName = 0
Private Const micControlLabel = 1
Private Const micControlType = 2
Private Const micFilterField = 3
Private Const micFieldType = 4

'Constant to indicate a control is sitting on the form (not on the page of a tab control.)
Private Const mlngcOnTheForm = -1&

'Module name (for error handler.)
Private Const conMod = "ajbFindAsUType"

Public Function FindAsUTypeLoad(frm As Form, ParamArray avarExceptionList()) As Boolean
On Error GoTo Err_Handler
'Purpose:       Initialize the code for Find.
'Return:        True on success.
'Arguments:     - frm = a reference to the form where you want this filtering.
'               - Optionally, you can specify controls NOT to offer filtering on, by putting the control names in quotes.
'Note:          The form must contain the 2 controls, cboFindAsUTypeField and txtFindAsUTypeValue,
'                   with the combo set up correctly.
'Usage:         Set the Load event procedure of the form to:
'                   Call FindAsUType(Me)
'               To suppress filtering on controls FirstName and City, use:
'                   Call FindAsUType(Me, "FirstName", "City")
    Dim rs As DAO.Recordset                 'Clone set of the form.
    Dim ctl As Control                      'Each control on the form.
    Dim strForm As String                   'Name of form (for error handler.)
    Dim strControl As String                'Name of the control.
    Dim strField As String                  'Name of the filter to use in the filter string.
    Dim strControlSource As String          'Name of the field the control is bound to.
    Dim strOut As String                    'List for the RowSource of cboFindAsUTypeField.
    Dim lngI As Long                        'Loop counter.
    Dim lngJ As Long                        'Page counter loop controller.
    Dim bSkip As Boolean                    'Flag to provide no filtering for this control.
    Dim bResult As Boolean                  'Return value for this function.
    Dim lngParentNumber As Long             '-1 if the control is directly on the form, else PageIndex of it parent.
    Dim lngMaxParentNumber As Long          'PageIndex of last page of tab control. -1 if no tab control.
    Dim astrControls() As String            'Array to handle the controls on the form.
    Const lngcControl = 0&                  'First element of array astrControls is the control name.
    Const lngcField = 1&                    'Second element of the array is the field name to filter on.

    'The form must have a control source if we are to filter it, and needs our 3 controls.
    strForm = frm.Name

    If HasUnboundControls(frm, "cboFindAsUTypeField", "txtFindAsUTypeValue") And (frm.RecordSource  vbNullString) Then
        'Set the event handers for the 2 controls
        frm!cboFindAsUTypeField.AfterUpdate = "=FindAsUTypeChange([Form])"
        frm.txtFindAsUTypeValue.OnChange = "=FindAsUTypeChange([Form])"
        'Calculate the number of pages on the tab control if there is one.
        lngMaxParentNumber = MaxParentNumber(frm)

        'Declare an array large enough to handle the controls on the form,
        '    for each page of any tab control (since these have their own tab index),
        '    and for storing the control name and the filter field name.
        ReDim astrControls(0& To frm.Controls.Count - 1&, mlngcOnTheForm To lngMaxParentNumber, lngcControl To lngcField) As
String
        Set rs = frm.RecordsetClone             'For info about the fields the controls are bound to.

        'Loop through the controls on the form.
        For Each ctl In frm.Controls
            'Ignore hidden controls, and limit ourselves to text boxes and combos.
            If ctl.Visible Then
                If (ctl.ControlType = acTextBox) Or (ctl.ControlType = acComboBox) Then
                    bSkip = False
                    strField = vbNullString
                    strControl = ctl.Name
                    'Ignore if the control name is in the exception list.
                    For lngI = LBound(avarExceptionList) To UBound(avarExceptionList)
                        If avarExceptionList(lngI) = strControl Then
                            bSkip = True
                            Exit For
                        End If
                    Next

                    If Not bSkip Then
                        'Ignore if unbound, or bound to an expression.
                        strControlSource = ctl.ControlSource
                        If (strControlSource = vbNullString) Or (strControlSource Like "=*") Then
                            bSkip = True
                        Else
                            'Ignore yes/no fields, binary (JET uses for unknown), and complex data types (> 100.)
                            Select Case rs(strControlSource).Type
                            Case dbBoolean, dbLongBinary, dbBinary, dbGUID, Is > 100
                                bSkip = True
                            End Select
                        End If
                    End If

                    'Ignore if we cannot specify the field to filter on.
                    If Not bSkip Then
                        strField = GetFilterField(ctl)
                        If strField = vbNullString Then
                            bSkip = True
                        End If
                    End If

                    'Add this control name to our array, in the order of the tab index.
                    If Not bSkip Then
                        lngParentNumber = ParentNumber(ctl)
                        astrControls(ctl.TabIndex, lngParentNumber, lngcControl) = strControl
                        astrControls(ctl.TabIndex, lngParentNumber, lngcField) = strField
                    End If
                End If
            End If
        Next

        'Loop through the array of controls, to build the string for the RowSource of cboFindAsUTypeField (5 columns.)
        For lngJ = LBound(astrControls, 2) To UBound(astrControls, 2)
            For lngI = LBound(astrControls) To UBound(astrControls)
                If astrControls(lngI, lngJ, lngcControl)  vbNullString Then
                    Set ctl = frm.Controls(astrControls(lngI, lngJ, lngcControl))
                    strOut = strOut & """" & ctl.Name & """" & mstrcSep & _
                        """" & Caption4Control(frm, ctl) & """" & mstrcSep & _
                        ctl.ControlType & mstrcSep & _
                        """" & astrControls(lngI, lngJ, lngcField) & """" & mstrcSep & _
                        """" & rs(ctl.ControlSource).Type & """" & mstrcSep
                End If
            Next
        Next
        rs.Close

        'Remove the trailing separator, and assign to the RowSource of cboFindAsUTypeField.
        lngI = Len(strOut) - Len(mstrcSep)
        If lngI > 0 Then
            With frm.cboFindAsUTypeField
                .RowSource = Left(strOut, lngI)
                .Value = .ItemData(0)           'Initialize to the first item in the list.
            End With
            bResult = True                      'Return True: the list loaded successfully.
        End If
    End If

    'Show the filter controls. (Separate routine, since they could fail if the control does not exist.)
    Call ShowHideControl(frm, "cboFindAsUTypeField", bResult)
    Call ShowHideControl(frm, "txtFindAsUTypeValue", bResult)

    'Return value
    FindAsUTypeLoad = bResult

Exit_Handler:
    Set ctl = Nothing
    Set rs = Nothing
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".FindAsUTypeLoad", "Form " & strForm)
    Resume Exit_Handler
End Function

Public Function FindAsUTypeChange(frm As Form) As Boolean
On Error GoTo Err_Handler
    'Purpose:   Filter the form, by the control named in cboFindAsUTypeField and the value in txtFindAsUTypeValue.
    'Return:    True unless an error occurred.
    'Usage:     The code assigns this to the Change event of the text box, and the AfterUpdate event of the combo.
    Dim strText As String      'The text of the text box.
    Dim lngSelStart As Long    'Selection Starting point.
    Dim strField As String     'Name of the field to filter on.
    Dim bHasFocus As Boolean   'True if the text box has focus (since it can be called from the combo too.)
    Const strcTextBox = "txtFindAsUTypeValue"

    'If the text box has focus, remember the selection insert point and use its Text. Otherwise use its Value.
    bHasFocus = (frm.ActiveControl.Name = strcTextBox)
    If bHasFocus Then
        strText = frm!txtFindAsUTypeValue.Text
        lngSelStart = frm!txtFindAsUTypeValue.SelStart
    Else
        strText = Nz(frm!txtFindAsUTypeValue.Value, vbNullString)
    End If

    'Save any uncommitted edits in the form. (This loses the insertion point, and converts Text to Value.)
    If frm.Dirty Then
        frm.Dirty = False
    End If

    'Read the filter field name from the combo.
    strField = Nz(frm.cboFindAsUTypeField.Column(micFilterField), vbNullString)

    'Unfilter if there is no text to find, or no control to filter. Otherwise, filter.
    If (strText = vbNullString) Or (strField = vbNullString) Then
        frm.FilterOn = False
    Else
        frm.Filter = strField & " Like """ & IIf(mbcStartOfField, vbNullString, mstrcWildcardChar) & _
        strText & mstrcWildcardChar & """"
        frm.FilterOn = True
    End If

    'If the control had focus, restore focus if necessary, and set the insertion point.
    If bHasFocus Then
        If frm.ActiveControl.Name  strcTextBox Then
            frm(strcTextBox).SetFocus
        End If
        If strText  vbNullString Then
            frm!txtFindAsUTypeValue = strText
            frm!txtFindAsUTypeValue.SelStart = lngSelStart
        End If
    End If

    'Return True if the routine completed without error.
    FindAsUTypeChange = True

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2474
        Resume Next
    Case 2185   'Text box loses focus when no characters left.
        Resume Exit_Handler
    Case Else
        MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "txtFindAsUTypeValue_Change"
        Resume Exit_Handler
    End Select
End Function

Private Function Caption4Control(frm As Form, ctl As Control) As String
On Error GoTo Err_Handler
    'Purpose: Choose the name by which the user knows this control.
    Dim strCaption As String

    '1st choice: Assign the caption of the attached label.
    strCaption = ctl.Controls(0).Caption

    '2nd choice: Read the caption from the label over the column in a continuous form.
    If strCaption = vbNullString Then
        strCaption = CaptionFromHeader(frm, ctl)
    End If

    'Strip the trailing semicolon.
    If Right$(strCaption, 1&) = ":" Then
        strCaption = Left$(strCaption, Len(strCaption) - 1&)
    End If

    'Strip the ampersand hotkey.
    If InStr(strCaption, "&") > 0& Then
        strCaption = Replace(strCaption, "&&", Chr$(31))
        strCaption = Replace(strCaption, "&", vbNullString)
        strCaption = Replace(strCaption, Chr$(31), "&")
    End If

    '3rd choice: Use the control name.
    If strCaption = vbNullString Then
        strCaption = ctl.Name
    End If

    Caption4Control = strCaption

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2467&
        Resume Next
    Case Else
        MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "Caption4Control()"
        Resume Exit_Handler
    End Select
End Function

Private Function CaptionFromHeader(frm As Form, ctl As Control) As String
On Error GoTo Err_Handler
    'Purpose:   Look for a label in the column header, directly over the control, in continuous form view.
    'Return:    Caption of the label if found.
    Dim ctlHeader As Control    'controls in the header of the form.
    Const icRadius = 120        'one twelveth of an inch, in twips.

    'If we are in Form view, and it's a Continuous Form,
    '    and there is a label in the Form Header directly above the column, return its Caption.
    If (frm.CurrentView = 1) And (frm.DefaultView = 1) Then
        For Each ctlHeader In frm.Section(acHeader).Controls
            If ctlHeader.ControlType = acLabel Then
                If (ctlHeader.Left > ctl.Left - icRadius) And (ctlHeader.Left < ctl.Left + icRadius) Then
                    CaptionFromHeader = ctlHeader.Caption
                End If
            End If
        Next
    End If

Exit_Handler:
    Set ctlHeader = Nothing
    Exit Function

Err_Handler:
    If Err.Number  2462& Then     'No such Section.
        Call LogError(Err.Number, Err.Description, conMod & ".CaptionFromHeader")
    End If
    Resume Exit_Handler
End Function

Private Function HasUnboundControls(frm As Form, ParamArray avarControlNames()) As Boolean
On Error GoTo Err_Handler
    'Purpose: Return true if all the controls named in the array are present on the form, and are unbound.
    Dim lngI As Long
    Dim bCancel As Boolean

    If UBound(avarControlNames) > 0& Then
        'Loop through the named controls on the form.
        For lngI = LBound(avarControlNames) To UBound(avarControlNames)
            If frm.Controls(avarControlNames(lngI)).ControlSource  vbNullString Then
                bCancel = True
                Exit For
            End If
        Next
        'If we did not drop to the error handler, the form has the named controls.
        HasUnboundControls = Not bCancel
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Resume Exit_Handler
End Function

Private Function MaxParentNumber(frm As Form) As Long
On Error GoTo Err_Handler
    'Purpose:   Return the PageIndex of the tab page that the control is on.
    'Return:    -1 if setting directly on the form, else the PageIndex of the last page of the tab control.
    'Note:      PageIndex is zero based, so subtract 1 from the count of pages.
    Dim ctl As Control          'Each control on the form.
    Dim lngReturn As Long

    lngReturn = mlngcOnTheForm  'Initialize to no tab control.
    For Each ctl In frm.Controls
        If ctl.ControlType = acTabCtl Then
            lngReturn = ctl.Pages.Count - 1
            Exit For            'A form can have only one tab control.
        End If
    Next

    MaxParentNumber = lngReturn

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".MaxParentNumber")
    Resume Exit_Handler
End Function

Private Function ParentNumber(ctl As Control) As Integer
On Error Resume Next
    'Purpose:   Return the PageIndex of the tab page that the control is on.
    'Return:    -1 if setting directly on the form, else the page of the tab control.
    'Note:      This works for text boxes and combos, not for labels or controls in an option group.
    Dim iReturn As Integer

    iReturn = ctl.Parent.PageIndex
    If Err.Number  0& Then
        iReturn = mlngcOnTheForm
    End If
    ParentNumber = iReturn
End Function

Private Function ShowHideControl(frm As Form, strControlName As String, bShow As Boolean) As Boolean
On Error Resume Next
    'Purpose:   Show or hide a control on the form, without error message.
    'Return:    True if the contorl's Visible property was set successfully.
    'Arguments: frm = a reference to the form where the control is expected.
    '           strControlName = the name of the control to show or hide.
    '           bShow = True to make visible; False to make invisible.
    'Note:      This is a separate routine, since hiding a non-existant control will error.
    frm.Controls(strControlName).Visible = bShow
    ShowHideControl = (Err.Number = 0&)
End Function

Private Function GetFilterField(ctl As Control) As String
On Error GoTo Err_Handler
    'Purpose:   Determine the field name to use when filtering on this control.
    'Return:    The field name the control is bound to, except for combos.
    '               In Access 2002 and later, we return the syntax Access uses for filtering these controls.
    'Argument:  The control we are trying to filter.
    'Note:      We don't use the Recordset of the combo, because:
    '               a) it's not supported earlier than Access 2002, and
    '               b) it's often not loaded at this point.
    '               Instead, we OpenRecordset to get the source field name,
    '               which works even if the field is aliased in the RowSource.
    '               Opening for append only is quicker, as it loads no existing records.
    Dim rs As DAO.Recordset     'To get information about the combo's RowSource.
    Dim iColumn As Integer      'The first visible column of the combo (zero-based.)
    Dim strField As String      'Return value: the field name to use for the filter string.
    Dim bCancel As Boolean      'Flag to not filter on this control.

    If ctl.ControlType = acComboBox Then
        iColumn = FirstVisibleColumn(ctl)
        If iColumn = ctl.BoundColumn - 1 Then
            'The bound column is the first visible column: filter on the control source field.
            strField = "[" & ctl.ControlSource & "]"
        Else
            'In Access 2002 and later, we can use the lookup syntax Access uses, if the source is a Table/Query.
            If Int(Val(SysCmd(acSysCmdAccessVer))) >= 10 Then
                If ctl.RowSourceType = "Table/Query" Then
                    Set rs = DBEngine(0)(0).OpenRecordset(ctl.RowSource, dbOpenDynaset, dbAppendOnly)
                    With rs.Fields(iColumn)
                        strField = "[Lookup_" & ctl.Name & "].[" & .SourceField & "]"
                    End With
                    rs.Close
                Else
                    bCancel = True  'Hidden bound column not supported if RowSourceType is Value List or call-back function.
                End If
            Else
                bCancel = True      'Hidden bound column not supported for versions earlier than Access 2002.
            End If
        End If
    Else
        'Not a combo: filter on the control source field.
        strField = "[" & ctl.ControlSource & "]"
    End If

    If strField  vbNullString Then
        GetFilterField = strField
    ElseIf Not bCancel Then
        GetFilterField = "[" & ctl.ControlSource & "]"
    End If

Exit_Handler:
    Set rs = Nothing
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".GetFilterField")
    Resume Exit_Handler
End Function

Private Function FirstVisibleColumn(cbo As ComboBox) As Integer
On Error GoTo Err_Handler
    'Purpose:   Return the column number of the first visible column in a combo.
    'Return:    Column number. ZERO-BASED!
    'Argument:  The combo to examine.
    'Note:      Also returns zero on error.
    Dim i As Integer            'Loop controller.
    Dim varArray As Variant     'Array of the combo's ColumnWidths values.
    Dim iResult As Integer      'Colum number to return.
    Dim bFound As Boolean       'Flag that we found a value to return.

    If cbo.ColumnWidths = vbNullString Then
        'If no column widths are specified, the first column is visible.
        iResult = 0
        bFound = True
    Else
        'Parse the ColumnWidths string into an array, and find the first non-zero value.
        varArray = Split(cbo.ColumnWidths, mstrcSep)
        For i = LBound(varArray) To UBound(varArray)
            If varArray(i)  0 Then
                iResult = i
                bFound = True
                Exit For
            End If
        Next
        'If the column widths ran out before all columns were checked, the next column is the first visible one.
        If Not bFound Then
            If i < cbo.ColumnCount Then
                iResult = i
                bFound = True
            End If
        End If
    End If

    FirstVisibleColumn = iResult

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".FirstVisibleColumn")
    Resume Exit_Handler
End Function

'------------------------------------------------------------------------------------------------
'You may prefer to replace this with a true error logger. See http://allenbrowne.com/ser-23a.html
Private Function LogError(ByVal lngErrNumber As Long, ByVal strErrDescription As String, _
    strCallingProc As String, Optional vParameters, Optional bShowUser As Boolean = True) As Boolean
On Error GoTo Err_LogError
    'Purpose:   Generic error handler.
    'Arguments: lngErrNumber - value of Err.Number
    '           strErrDescription - value of Err.Description
    '           strCallingProc - name of sub|function that generated the error.
    '           vParameters - optional string: List of parameters to record.
    '           bShowUser - optional boolean: If False, suppresses display.
    'Author:    Allen Browne, allen@allenbrowne.com

    Dim strMsg As String    'String for display in MsgBox

    Select Case lngErrNumber
    Case 0
        Debug.Print strCallingProc & " called error 0."
    Case 2501               'Cancelled
        'Do nothing.
    Case 3314, 2101, 2115   'Can't save.
        If bShowUser Then
            strMsg = "Record cannot be saved at this time." & vbCrLf & _
                "Complete the entry, or press  to undo."
            MsgBox strMsg, vbExclamation, strCallingProc
        End If
    Case Else
        If bShowUser Then
            strMsg = "Error " & lngErrNumber & ": " & strErrDescription
            MsgBox strMsg, vbExclamation, strCallingProc
        End If
        LogError = True
    End Select

Exit_LogError:
    Exit Function

Err_LogError:
    strMsg = "An unexpected situation arose in your program." & vbCrLf & _
        "Please write down the following details:" & vbCrLf & vbCrLf & _
        "Calling Proc: " & strCallingProc & vbCrLf & _
        "Error Number " & lngErrNumber & vbCrLf & strErrDescription & vbCrLf & vbCrLf & _
        "Unable to record because Error " & Err.Number & vbCrLf & Err.Description
    MsgBox strMsg, vbCritical, "LogError()"
    Resume Exit_LogError
End Function



Hi All,

I'm in the process of creating a database that allows users to enter details into a form which includes a date range as start and end dates.

I have used the inbuilt Calendar Control 10.0 control to allow users to select the date. It is linked to two combo boxes [cmbStartDate] and [cmbEndDate] using the following code (this code is repeated for each combo box):

Code:

Private Sub cmbStartDate_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Set cmbOriginator = cmbStartDate

ocxCalendar.Visible = True

ocxCalendar.SetFocus

If Not IsNull(cmbStartDate) Then

ocxCalendar.Value = cmbStartDate.Value

Else

ocxCalendar.Value = Date

End If
End Sub



And..

Private Sub ocxCalendar_Click()

''Update the ComboBox with the value entered into the ComboBox
''Put the value back into the relevant ComboBox
cmbOriginator.Value = ocxCalendar.Value

''Hide the calendar
cmbOriginator.SetFocus
ocxCalendar.Visible = False

''Clear the variable
Set cmbOriginator = Nothing

End Sub

This all seems to work fine- however, when I try to write the selected dates to a table or use them in a query they are not recognised (the form obviously needs to be open whilst the query runs), but if I manually type dates into these combo boxes these dates are picked up fine.

This is beginning to drive me mad so any help would be greatly appreciated.

Mark

What I have is 1 main form (let's say: MF) and 2 subforms (say SF1 and SF2). Both are to be positioned beneath the fields of MF.

SF1 is always present but can have varying number of records (i.e. its height will not remain constant).

SF2 is optionally present, depending on checkbox in MF and will appear beneath SF1.

I have this working by setting first:- SF1.Height to be number of records * height of row + 1 height of row (for new record entry) and then, second: setting SF2.Top to be SF1.Top + SF1.Height.

This does work well enough, but...

If any access is made to SF1 (even a click with no actual entry) and the MF is then changed to a different record, the whole of MF (incl SF's) shifts up about a centimetre with the top fields disappearing into (behind) the Form's Header (and my code results in a vertical scroll bar appearing where none is ever needed).

I have tried just about all possible variables of AutoSize, Can Grow, Can shrink etc for MF and SF's but nothing has any effect.

I have put in a dummy field, at the very top of MF, to take focus on Current which either prevents or recovers from the abnormal shift, but i'm not happy knowing there's a problem still there.

Below is my code. My Access (and certainly my VBA) knowledge is very weak so would appreciate any insight from those more experienced...

Private Sub Form_Current()
Me!TxtDummy.SetFocus ''''This is to counter the unexplained shift up of form after accessing sForm_OTbyDay ?!!

'Show/Hide Transport subform as required - by record's Transport Y/N value
If (Me!CheckTransport = -1) Then
Me!sFormTransport.Visible = True
Else
Me!sFormTransport.Visible = False
End If

'''''''''''''''''

'Change position of sFormTransport as sForm_OTbyDay resizes
''' 1cm = 567twips
Dim rowsCount As Integer 'Number of rows in OTDaybyDay subForm
Dim yRowHeight As Integer 'Row height in Twips of OTDaybyDay subForm
Dim headerHeight As Integer 'Header height of OTDaybyDay subForm
Dim sf1Top 'Vertical position of 1st subform
Dim sf2Top 'Vertical position of 2nd subform
yRowHeight = 450
headerHeight = 330
rowsCount = Me.Controls("sForm_OTbyDay").Form.Recordset.Record Count
sf1Top = Me![sForm_OTbyDay].Top

Me![sForm_OTbyDay].Height = (sf1Top + headerHeight) + (rowsCount * yRowHeight) + yRowHeight

If (Me!sFormTransport.Visible = True) Then
Me![sFormTransport].Top = Me![sForm_OTbyDay].Height
End If

End Sub

Glenn

Please I need some help. I have been working to duplicate a function that works great in the Sample DB Northwind.mdb which is included in the MS Office XP installation.

The function I need is the Photo function that allows for adding and updating the Employee photo in the Employee Form. I have tried copying the code in the functions and Modules section and duplicate the buttons (I used Different names but adjusted the code accordingly). After several hours of getting the error "Variable Undefined" for the argument (msoFileDialogFilePicker) in the "Sub getFileName()" section I found that problem and corrected for it.

Now the code shows unsupported function or action for the "If",Marked in Bold and Underlined in this post, statement just below that and when I comment that section out the code runs and it shows me the Access File Open window in the correct Directory but no matter what I do I can't select a file by clicking or double clicking or even typing the file name in. I can right click the image frame and select the correct picture using the function in the drop down list but that is the only way I can do it and I can't depend on the users who will be using it to do this process correctly.

Here is the code I have so far:

Module 1:


	Code:
	Option Compare Database
Option Explicit

Public Function DisplayImage(ctlImageControl As Control, strImagePath As Variant) As String
On Error GoTo Err_DisplayImage

Dim strResult As String
Dim strDatabasePath As String
Dim intSlashLocation As Integer

With ctlImageControl
    If IsNull(strImagePath) Then
        .Visible = False
        strResult = "No image name specified."
    Else
        If InStr(1, strImagePath, "") = 0 Then
            ' Path is relative
            strDatabasePath = CurrentProject.FullName
            intSlashLocation = InStrRev(strDatabasePath, "", Len(strDatabasePath))
            strDatabasePath = Left(strDatabasePath, intSlashLocation)
            strImagePath = strDatabasePath & strImagePath
        End If
        .Visible = True
        .Picture = strImagePath
        strResult = "Image found and displayed."
    End If
End With
    
Exit_DisplayImage:
    DisplayImage = strResult
    Exit Function

Err_DisplayImage:
    Select Case Err.Number
        Case 2220       ' Can't find the picture.
            ctlImageControl.Visible = False
            strResult = "Can't find image in the specified name."
            Resume Exit_DisplayImage:
        Case Else       ' Some other error.
            MsgBox Err.Number & " " & Err.Description
            strResult = "An error occurred displaying image."
            Resume Exit_DisplayImage:
    End Select
End Function



form New Employee Functions:


	Code:
	Option Compare Database
Option Explicit
Dim path As String

Private Sub Save_Click()
On Error GoTo Err_Save_Click
    
    DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70

Exit_Save_Click:
    Exit Sub

Err_Save_Click:
    MsgBox Err.Description
    Resume Exit_Save_Click
    
End Sub

Private Sub AddPicture_Click()
    ' Use the Office File Open dialog to get a file name to use
    ' as an employee picture.
    getFileName
End Sub

Private Sub Form_RecordExit(Cancel As Integer)
    ' Hide the errormsg label to reduce flashing when navigating
    ' between records.
    errormsg.Visible = False
End Sub

Private Sub RemovePicture_Click()
    ' Clear the file name for the employee record and display the
    ' errormsg label.
    Me![ImagePath] = ""
    hideImageFrame
    errormsg.Visible = True
End Sub

Private Sub Form_AfterUpdate()
    ' Requery the ReportsTo combo box after a record has been changed.
    ' Then, either show the errormsg label if no file name exists for
    ' the employee record or display the image if there is a file name that
    ' exists.
    Me!ReportsTo.Requery
    On Error Resume Next
        showErrorMessage
        showImageFrame
        If (IsRelative(Me!ImagePath) = True) Then
            Me![ImageFrame].Picture = path & Me![ImagePath]
        Else
            Me![ImageFrame].Picture = Me![ImagePath]
        End If
End Sub

Private Sub ImagePath_AfterUpdate()
    ' After selecting an image for the employee, display it.
    On Error Resume Next
        showErrorMessage
        showImageFrame
        If (IsRelative(Me!ImagePath) = True) Then
            Me![ImageFrame].Picture = path & Me![ImagePath]
        Else
            Me![ImageFrame].Picture = Me![ImagePath]
        End If
End Sub
Private Sub Form_Current()
    ' Display the picture for the current employee record if the image
    ' exists.  If the file name no longer exists or the file name was blank
    ' for the current employee, set the errormsg label caption to the
    ' appropriate message.
    Dim res As Boolean
    Dim fName As String
    
    path = CurrentProject.path
    On Error Resume Next
        errormsg.Visible = False
        If Not IsNull(Me!Photo) Then
            res = IsRelative(Me!Photo)
            fName = Me![ImagePath]
            If (res = True) Then
                fName = path & "" & fName
            End If
            
            Me![ImageFrame].Picture = fName
            showImageFrame
            Me.PaintPalette = Me![ImageFrame].ObjectPalette
            If (Me![ImageFrame].Picture  fName) Then
                hideImageFrame
                errormsg.Caption = "Picture not found"
                errormsg.Visible = True
            End If
        Else
            hideImageFrame
            errormsg.Caption = "Click Add/Change to add picture"
            errormsg.Visible = True
        End If

End Sub

Sub getFileName()
    ' Displays the Office File Open dialog to choose a file name
    ' for the current employee record.  If the user selects a file
    ' display it in the image control.
    Dim fileName As String
    Dim result As Integer
    
    With Application.FileDialog(msofileDialogFilePicker)
        .Title = "Select Employee Picture"
        .Filters.Add "All Files", "*.*"
        .Filters.Add "JPEGs", "*.jpg"
        .Filters.Add "Bitmaps", "*.bmp"
        .FilterIndex = 3
        .AllowMultiSelect = False
        .InitialFileName = CurrentProject.path
        result = .Show
        If (result  0) Then
            fileName = Trim(.SelectedItems.Item(1))
            Me![ImagePath].Visible = True
            Me![ImagePath].SetFocus
            Me![ImagePath].Text = fileName
            Me![FirstName].SetFocus
            Me![ImagePath].Visible = False
        End If
    End With
End Sub

Sub showErrorMessage()
    ' Display the errormsg label if the image file is not available.
    If Not IsNull(Me!Photo) Then
        errormsg.Visible = False
    Else
        errormsg.Visible = True
    End If
End Sub

Function IsRelative(fName As String) As Boolean
    ' Return false if the file name contains a drive or UNC path
    IsRelative = (InStr(1, fName, ":") = 0) And (InStr(1, fName, "") = 0)
End Function

Sub hideImageFrame()
    ' Hide the image control
    Me![ImageFrame].Visible = False
End Sub



I'm having problems setting the visibility of a command button to false after it's been clicked, and I'm not sure why.

When the user clicks the button, it's supposed to finish the on click sub by setting focus into the subform that becomes visible as a result of the click, and then set visible = false. I make sure the subform is visible before setting focus, and make sure to mention the control specifically when doing the Set Focus call. I still get the 2165 Error "You can't hide a control that has the focus".

I've tried multiple different setups for setting the subform visibility (which works fine every time) setting the focus (which apparently doesn't, even though I know the sub is getting called and not returning errors) and setting the visibility of the command button.

I'm pretty sure the problem lies with the SetFocus not taking effect before the visibility = false is called, but I've tried using a repaint as recommended in the Set Focus docs and that still didn't solve the problem. Anyone have any idea what's going wrong?

Thanks for looking.

I have an access 2000 database which is quite large & complicated and contains about 70 forms and subforms in total. Opening and closing forms/subforms works fine most of the time, but on the odd occasion a form appears which isn't supposed to. This isn't too much of a problem for users with knowledge of how the system is supposed to work, however i'd like to avoid an inexperienced user encountering something unexpected with the wrong form appearing.

It strikes me that their must be a standard way of controlling opening and closing of forms, in conjunction with setting their visible property, that keeps a database looking professional and which is 100% accurate.

At the moment i use two functions which create a "stack" of form names that have been and are being displayed which is ammended as forms are opened and closed, keeping track of the last form opened, and the previous form(s) to "fall back to" when the current form is closed.

the fucntions are "fpushscreen" for appending form names to the stack and "fpopscreen" for removing names from the stack.

Here's the code:

Public Function fPushScreen(cScreenName As String)

On Error GoTo PushScreen_err

'Check that this screen is not already on top of the stack
If cScreenName = aScreen(UBound(aScreen)) Then
'Yes, its a duplicate, so dont add it
Else
'Pushes a new screen name onto the stack
ReDim Preserve aScreen(UBound(aScreen) + 1)
aScreen(UBound(aScreen)) = cScreenName
End If
Exit Function

PushScreen_err:
ReDim aScreen(1)
aScreen(1) = "frmSwitchboard"

End Function
----------------------------------------------------------------
Public Function fPopScreen(Optional bClose As Boolean = False)

On Error GoTo PopScreen_err

'Hide or close the current form
If bClose Then
If Screen.ActiveForm.Name "frmSwitchboard" Then
DoCmd.Close
End If
Else
If Screen.ActiveForm.Name "frmSwitchboard" Then
Screen.ActiveForm.Visible = False
End If
End If

'Remove the last element from the stack and displays the screen underneath
ReDim Preserve aScreen(UBound(aScreen) - 1)
DoCmd.SelectObject acForm, aScreen(UBound(aScreen))
Screen.ActiveForm.SetFocus
Exit Function

PopScreen_err:
ReDim aScreen(1)
aScreen(1) = "frmSwitchboard"

End Function
-------------------------------------------------------------------------

Hope this is one that some clever person can get involved in as i know this is simple, but it is not 100% reliable and there must be a better way?

Thanks
Vince


Not finding an answer? Try a Google search.