MS Access VBA Delete

Hi ,



Problem Is When the user tries to multiple records at a time on the form . I do not want to let him do that. I should allow the user to delete one record at a time. So whenever the count of records ,that the user is trying to delete is more than 1 , cancel the operation . Whenever , the count is 1 , perform the deletion. PLease iam trying to achieve this in vba So please Help me out. Code please.
vihaanAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Dale FyeOwner, Developing Solutions LLCCommented:
I assume you are using a continuous form, and are allowing shortcut (right click) menus, or have the ribbon bar displayed.  It that assessment accurate.

I prevent this by:
1.  Hiding the ribbon bar using:

DisplayRibbon False

Public Sub DisplayRibbon(Optional IsVisible As Boolean = True)

    Dim intAction As Integer
   
    If Application.Version < 12 Then
        'do nothing
    ElseIf IsVisible Then
        DoCmd.ShowToolbar "Ribbon", acToolbarYes
    Else
        DoCmd.ShowToolbar "Ribbon", acToolbarNo
    End If
   
End Sub

2.  either disabling the shortcut menu on the form or creating my own.

3.  I then add my own delete button to the forms footer.  Since only one record can actually have the focus at a time, using the delete button to delete the record that currently has the focus

Private Sub cmd_Delete_Click

    Dim strSQL as string

    strSQL = "DELETE * FROM yourTable WHERE ID = " & me.txt_ID
    currentdb.execute strsql, dbfailonerror

    me.requery

End Sub
vihaanAuthor Commented:
HI FYed. thanks alot for replying. But  the first answer does not apply because i am using 2003 and instead of going through other answers, which you have sent. Can i do that through code in vba.
Dale FyeOwner, Developing Solutions LLCCommented:
It's been a while since I have used 2003, but as I recall, in one of the main menus, you can turn off the standard menu bar and hide the database window.  I generally do this in all of the applications that I wrote for someone else.  Then, I would create my own "menus" on each of my forms, using labels across the top of each form.  Each of these labels would be tied to a shortcut menu via the click event (see example)

Private sub lbl_Form_Click

    CommandBars("MyFormMenu").ShowPopup

End Sub

This technique allows me to set the forms "Shortcut Menu" property to False to disable the right click shortcuts.

Then, I use vba code (see code segments below) to actually create the shortcut menus.  This method is extremely flexible, and much more portable than the standard method of customizing the toolbars.  The attached code module contains several of the subroutines I use for creating shortcut menus, and the function code associated with them.


Option Compare Database
Option Explicit

Const BarPopup = 5
Const ControlButton = 1
Const ControlEdit = 2
Const ControlComboBox = 4
Const ButtonUp = 0
Const ButtonDown = -1
Public Function CmdBarExists(BarName As String) As Boolean

    Dim intControls
    
    On Error Resume Next
    intControls = CommandBars(BarName).Controls.Count
    If Err.Number = 0 Then
        CmdBarExists = True
    Else
        CmdBarExists = False
    End If
    
End Function
Public Sub DeleteCmdBar(BarName As String)

    Dim intLoop As Integer
    
    'If an error is generated, it is because the command bar doesn't exist, ignore it
    On Error GoTo DeleteCmdBar_Error
    CommandBars(BarName).Delete
    Exit Sub
    
DeleteCmdBar_Error:
    Err.Clear
    
End Sub

Public Sub MenuForm()

    Dim cbr As Object
    Dim cbrButton As Object

    If CmdBarExists("MyFormMenu") Then Exit Sub
    On Error GoTo FormMenuError

    DoCmd.Hourglass True

    Set cbr = CommandBars.Add("MyFormMenu", BarPopup, , True)

    With cbr

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Close"
            .Tag = "Close"
            .OnAction = "=fnCloseForm()"
        End With

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Quit"
            .Tag = "Quit"
            .OnAction = "=fnQuit()"
        End With

    End With

    DoCmd.Hourglass False
    Exit Sub
FormMenuError:
    MsgBox "ReportMenu error" & vbCrLf
End Sub

Public Function fnCloseForm()

    Dim frm As Form
    
    Set frm = Screen.ActiveForm
    
    On Error Resume Next
    frm.AllowClose = True
    DoCmd.Close acForm, frm.Name
    
End Function

Public Function fnQuit()

    Dim intFormLoop As Integer
    Dim frm As Form
    
    For intFormLoop = Forms.Count To 1 Step -1
        Set frm = Forms(intFormLoop - 1)
        On Error Resume Next
        frm.AllowClose = True
        DoCmd.Close acForm, frm.Name
    Next
    
    DoCmd.Quit
    
End Function

Public Sub MenuText(Optional Reset As Boolean = False)

    Dim cbr As Object
    Dim cbrButton As Object

    'If the commandbar exists, and Reset is false, then exit
    If CmdBarExists("MyTextMenu") Then
        If Reset = False Then
            Exit Sub
        Else
            DeleteCmdBar "MyTextMenu"
        End If
    End If
        
    On Error GoTo TextMenuError

    DoCmd.Hourglass True

    Set cbr = CommandBars.Add("MyTextMenu", BarPopup, , True)

    With cbr

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Copy"
            .Tag = "Copy"
            .OnAction = "=fnTextCopy()"
        End With

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Paste"
            .Tag = "Paste"
            .OnAction = "=fnTextPaste()"
        End With

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .begingroup = True
            .Caption = "&Spell check"
            .Tag = "Spell check"
            .OnAction = "=fnTextSpell()"
        End With

    End With

    DoCmd.Hourglass False
    Exit Sub
    
TextMenuError:
    MsgBox Err.Number & vbCrLf & Err.Description, vbInformation + vbOKOnly, "TextMenu error:"
    
End Sub

Public Function fnTextCopy()

    Dim frm As Form
    Dim ctrl As Control
    
    Set frm = Screen.ActiveForm
    Do While frm.ActiveControl.ControlType = acSubform
        Set frm = frm.ActiveControl.Form
    Loop
    Set ctrl = frm.ActiveControl
    
    If ctrl.SelLength = 0 Then
        ctrl.SelStart = 0
        ctrl.SelLength = Len(ctrl.Text)
    End If
    
    DoCmd.RunCommand acCmdCopy
        
End Function

Public Function fnTextPaste()

    Dim frm As Form
    Dim ctrl As Control
    
    On Error GoTo TextPasteError
    
    Set frm = Screen.ActiveForm
    Do While frm.ActiveControl.ControlType = acSubform
        Set frm = frm.ActiveControl.Form
    Loop
    Set ctrl = frm.ActiveControl
    
    DoCmd.RunCommand acCmdPaste
    Exit Function
TextPasteError:
    If Err.Number = 2046 Then
        Resume Next
    Else
        DisplayError ("Error encountered while attempting to paste text!")
    End If
End Function
Public Function fnTextSpell()

    Dim frm As Form
    Dim ctrl As TextBox
    
    On Error GoTo SpellError
    
    Set frm = Screen.ActiveForm
    Do While frm.ActiveControl.ControlType = acSubform
        If Application.Version > 11 And Application.Build < 6322 Then
            MsgBox "Unable to spell check this item!"
            Exit Function
        Else
            Set frm = frm.ActiveControl.Form
        End If
    Loop
    
    Set ctrl = frm.ActiveControl
    With ctrl
        
        If ctrl.SelLength = 0 Then
            ctrl.SelStart = 0
            ctrl.SelLength = Len(ctrl.Text)
        End If
    
    End With
    
    If ctrl.SelLength > 0 Then DoCmd.RunCommand acCmdSpelling
    Exit Function

SpellError:
    DisplayError ("Error encountered by spell checker")
    
End Function




Public Sub MenuReport(Optional Reset As Boolean = False)

    Dim cbr As Object       'As CommandBar
    Dim cbrButton As Object
    Dim cbrCombo As Object   'CommandBarComboBox
    Dim cbrCombo1 As Object, cbrCombo2 As Object
    Dim cbrEdit As Object
    Dim strSQL As String
    Dim rs As DAO.Recordset

    If CmdBarExists("MyReportMenu") Then
        If Reset = False Then
            Exit Sub
        Else
            DeleteCmdBar ("MyReportMenu")
        End If
    End If
        
    On Error GoTo ReportMenuError

    DoCmd.Hourglass True

    Set cbr = CommandBars.Add("MyReportMenu", BarPopup, , True)

    With cbr

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Print"
            .Tag = "Print"
            .OnAction = "=fnReportPrint()"
        End With

        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "Save as &RTF"
            .Tag = "Save as RTF"
            .OnAction = "=fnReportSave('RTF')"
            .begingroup = True
        End With

        If IsPDFInstalled() = True Then
            Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
            With cbrButton
                .Caption = "Save as &PDF"
                .Tag = "Save as PDF"
                .OnAction = "=fnReportSave('PDF')"
            End With
        End If

        Set cbrCombo = cbr.Controls.Add(ControlComboBox, , , , True)
        With cbrCombo
            .Width = 0.25
            If (Application.Version = 12) And (IsPDFInstalled = True) Then
                .AddItem "PDF"
            End If
            .AddItem "RTF"
            .Caption = "Send as:"
            .Tag = "SendReport"
            .OnAction = "=fnReportSend()"
            .begingroup = True
        End With
            
        Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
        With cbrButton
            .Caption = "&Close"
            .Tag = "Close"
            .OnAction = "=fnReportClose()"
            .begingroup = True
        End With

    End With

    DoCmd.Hourglass False
    Exit Sub
ReportMenuError:
    MsgBox Err.Number & vbCrLf & Err.Description, , "ReportMenu error"
End Sub
Public Function fnReportPrint()

    Dim rpt As Report, strRptName As String
    Dim strMsg As String
    Dim intResponse As Integer, bPrint As Boolean

    On Error GoTo PrintReportError

    Set rpt = Reports(Reports.Count - 1)
    strRptName = rpt.Name
    
    bPrint = True

    If rpt.Pages > 10 Then
        strMsg = "This report contains " & rpt.Pages & " pages! " _
               & vbCrLf & vbCrLf _
               & "Print this report anyway?"
        intResponse = MsgBox(strMsg, vbOKCancel, "Excessive pages")
        If intResponse = vbCancel Then bPrint = False
    End If

    If bPrint Then
        With rpt
            Application.RunCommand acCmdPrint
        End With
    End If

    Exit Function

PrintReportError:
    If Err.Number = 2501 Then
        'do nothing (print was cancelled)
    Else
        DisplayError ("Error in fnReportPrint")
    End If

End Function
Public Function fnReportSave(OutputFormat As String)

    Dim rpt As Report
    
    On Error GoTo SaveReportError
    
    If Reports.Count = 0 Then
        Exit Function
    Else
        Set rpt = Reports(Reports.Count - 1)
    End If
    
    Select Case OutputFormat
        Case "HTML"
            DoCmd.OutputTo acOutputReport, rpt.Name, acFormatHTML, , True
        Case "RTF"
            DoCmd.OutputTo acOutputReport, rpt.Name, acFormatRTF, , True
        Case "PDF"
            DoCmd.OutputTo acOutputReport, rpt.Name, "PDF Format (*.pdf)", , True
        Case Else
            'do nothing
    End Select
    
SaveReportExit:
    Exit Function

SaveReportError:
    If Err.Number = 2501 Then
        Exit Function
    ElseIf Err.Number = 2282 Then
        MsgBox WrapText("Your system does not currently have the ability to save a file " _
                      & "in a PDF format." & vbCrLf _
                      & "Contact your system administrator to request addition of this " _
                      & "functionality to your suite of MS Office tools!", 65)
    Else
        DisplayError ("Error encountered while printing report")
    End If
End Function
Public Function fnReportSend()

    Dim cbr As Object
    Dim cbrCombo As Object
    Dim strFormat As String
    Dim rpt As Report, strReport As String
    Dim rs As DAO.Recordset
    
    Set rpt = Reports(Reports.Count - 1)
    strReport = rpt.Name
    
    Set cbr = CommandBars("MyReportMenu")
    Set cbrCombo = cbr.FindControl(Tag:="SendReport")
    If cbrCombo.ListCount = 1 Or cbrCombo.ListIndex = 2 Then
        strFormat = acFormatRTF
    Else
        strFormat = "PDF Format (*.pdf)"
    End If
    
    On Error GoTo ReportSendError
    
    DoCmd.SendObject acSendReport, strReport, strFormat, , , , "AWFC\LD Details", , True
    
ReportSendExit:
    Exit Function
    
ReportSendError:
    If Err.Number = 2501 Then
        MsgBox "Send email was cancelled!"
    ElseIf Err.Number = 2282 Then
        MsgBox WrapText("Your system does not currently have the ability to save a file " _
                      & "in a PDF format." & vbCrLf _
                      & "Contact your system administrator to request addition of this " _
                      & "functionality to your suite of MS Office tools!", 65)
    Else
        DisplayError ("Error encounterd during fnSendReport!")
    End If
    
End Function
Public Function fnReportClose()

    Dim rpt As Report
    Dim strMsg As String
    Dim intResponse As Integer, bPrint As Boolean

    On Error GoTo fnReportCloseError
    
    If Reports.Count > 0 Then
        DoCmd.Close acReport, Screen.ActiveReport.Name
'        DoCmd.Close acReport, Reports(Reports.Count - 1).Name
    End If
    
    Exit Function

fnReportCloseError:
    If Reports.Count > 0 Then strMsg = " Report: '" & Reports(Reports.Count - 1).Name & "'"
    strMsg = "Error encountered in fnCloseReport():" & strMsg
    DisplayError (strMsg)

End Function

Open in new window

Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

vihaanAuthor Commented:
Hi Fyed, thanks alot for replying but i am sorry i do not need all this. Because  when a user select multiple records on the continous form and right clicks on the mouse and selects cut it will delete multiple records. So in that case, i need some thing  OnDelete Event to say that mutliple records cannot be deleted . i should allow the user to delete only one record.

And i cannot  opt for cutsom meus or something like that because, the database has already been delivered to the users. and i am working on a new process which would capture deleted record information So regarding that process i trying to do this.  I need to achieve this through vba . if he tries to delete more than one record , a message prompt should appear saying he cannot . Please help me fyed. Iam really thankful to you.
Dale FyeOwner, Developing Solutions LLCCommented:
Sorry, can't help more than I have.

You might want to try the forms Before Delete event, but I know of no way to determine the number of records which are currently selected in a continuous form.

If you are going to make changes and send it to the customer, what difference does it make what process (standard or custom menues) you use to accomplish this?
vihaanAuthor Commented:
right now i am using the standard menu, I do not want to make any changes to the forms like adding buttons, textfields stufflike that. Because  this database is used different regions like 10 or so . and my supervisor definitely against it because it is not a godd practice to change what is working fine now. there are possibliites of going wrong. So thats why, i am kind of battling my way out.
Dale FyeOwner, Developing Solutions LLCCommented:
Sorry I couldn't be more help.  If you don't get any other responses in the next 24 hours, you might want to "Request Attention" by clicking the hyperlink in the bottom right corner of your original message.
vihaanAuthor Commented:
Thanks for trying .
vihaanAuthor Commented:
Hi Fyed, But could you check out my other thread may be i could use your help

http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_25856537.html#a30746743


check the last comment ( specifically). thank you,
answer_dudeCommented:
vihaan:

Add this code to your form module.  Be sure both your OnDelete and BeforeDelConfirm events are set after you paste this.
Dim globalDelete As Integer

Private Sub Form_Delete(Cancel As Integer)

    globalDelete = globalDelete + 1 ' Count records to delete
    Cancel = False

End Sub

Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)

    If (globalDelete) = 1 Then 'allow the delete
        Cancel = False

    End If
    
    If (globalDelete > 1) Then 'disallow the delete
        Cancel = True
        MsgBox "Deletion of multiple records not allowed"
    End If
    
    globalDelete = 0
    

End Sub

Open in new window

datAdrenalineCommented:
I would suggest you simply check for the number of records selected using the .SelHeight property and if it is > 1 then Cancel the delete .... something like this should do the trick:

Private Sub Form_Delete(Cancel As Integer)
   
    Static lngPromptBypassCounter As Long

    If Me.SelHeight > 1 Then
        Cancel = True
        lngPromptBypassCounter = lngPromptBypassCounter + 1
        If lngPromptBypassCounter = Me.SelHeight Then
            lngPromptBypassCounter = 0
            MsgBox "Can not delete more than one record at a time!"
        End If
    End If
   
End Sub


The reason for the lngPromptBypassCounter is because the event is fired for each record that is selected to be deleted, so the counter makes it so the user is only prompted once.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.