Vereenvoudigen VBA code

Status
Niet open voor verdere reacties.
M

Matjes

Gebruiker
Lid geworden
21 jun 2016
Berichten
76
Onderstaand heb ik twee procedures geschreven welke het zelfde doen: een primaire sleutel uit een brontabel zoeken en deze samen met een waarde uit het formulier in een andere brontabel plaatsen. De brontabel waarin de gegevens worden geplaatst heeft een unieke index van deze twee velden (dus een combinatie van deze twee velden mag maar één keer voorkomen). De codes werken. Echter zou ik een van deze codes graag vereenvoudigen en deze als definitief gaan toepassen op meerdere plekken in de database. Als iemand mij een suggestie kan doen, of een eerste aanzet kan doen, dan hoor ik graag. Ik ziet het even niet meer :rolleyes:

Code 1:
Code: 
Private Sub cboFabrikanttypeID_DblClick(Cancel As Integer)

End Sub
On Error GoTo ErrorHandler
'Doel gekozen fabrikanttypeID uit werktabel toevoegen aan brontabel waarbij fabrikanttypeID samen
'met een ander veld een unieke index vormen

'Controleren of in de combo's een geldige waarde uit de lijst gekozen is
If Me.cboObjecttypeID.ListIndex >= 0 And Me.cboFabrikanttypeID >= 0 Then

    'Bepalen of FabrikanttypeID al in brontabel aanwezig is tezamen met veld welke samen een index vormen
    'met unieke waarden
    If DCount("FabrikanttypeID", "tblSD_Fabrikanttype", _
        "SD_ID = " & DLookup("SD_ID", "tblSD", "SpanningID = " & Me.Parent!cboSpanningID _
        & " And VariantID = " & Me.Parent!cboVariantID _
        & " And ObjecttypeID = " & Me.cboObjecttypeID) _
        & " And FabrikanttypeID = " & Me.cboFabrikanttypeID & "") = 0 Then
        
        strTitle = "Bronbestand"
        strPrompt = "Fabrikanttype " & Me.cboFabrikanttypeID.Column(1) & " " & "toevoegen aan standaard?"
        intReturn = MsgBox(Prompt:=strPrompt, _
        buttons:=vbQuestion + vbYesNo, _
        Title:=strTitle)
    
        If intReturn = vbYes Then
                        
            DoCmd.SetWarnings False
    
            strSQL = "INSERT INTO tblSD_Fabrikanttype (SD_ID, FabrikanttypeID) " _
                & "SELECT SD_ID, " & Me.FabrikanttypeID & " FROM tblSD " _
                & "WHERE (((tblSD.ObjecttypeID)= " & Me.cboObjecttypeID & ") " _
                & "AND ((tblSD.SpanningID)=" & Me.Parent!cboSpanningID & ") " _
                & "AND ((tblSD.VariantID)= " & Me.Parent!cboVariantID & "));"
    
            DoCmd.RunSQL strSQL
            DoCmd.SetWarnings True
        End If
    Else
        strTitle = "Bronbestand"
        strPrompt = "Fabrikanttype " & Me.cboFabrikanttypeID.Column(1) & " " & "bestaat al"
        intReturn = MsgBox(Prompt:=strPrompt, _
        buttons:=vbOKOnly, _
        Title:=strTitle)
    End If
End If
 
ErrorHandlerExit:
    DoCmd.SetWarnings True
    Exit Sub

ErrorHandler:
        MsgBox "Error No: " & Err.Number & "; Description: " & _
        Err.Description
        Resume ErrorHandlerExit
End Sub

Code 2:
Code: 
Private Sub cboFabrikanttypeID_DblClick(Cancel As Integer)
On Error GoTo ErrorHandler

'Doel gekozen fabrikanttypeID uit werktabel toevoegen aan brontabel waarbij fabrikanttypeID samen
'met een ander veld een unieke index vormen

    'Controleren of in de combo's een geldige waarde uit de lijst gekozen is
    If Me.cboObjecttypeID.ListIndex >= 0 And Me.cboFabrikanttypeID >= 0 Then
    
    strTitle = "Bronbestand"
    strPrompt = "Fabrikanttype " & Me.cboFabrikanttypeID.Column(1) & " " & "toevoegen aan standaard?"
    intReturn = MsgBox(Prompt:=strPrompt, _
    buttons:=vbQuestion + vbYesNo, _
    Title:=strTitle)

        If intReturn = vbYes Then
    
            'Opzoeken SD_ID op basis van gegevens in hoofd/subformulier
            strSQL = "SELECT tblSD.SD_ID, tblSD.ObjecttypeID, tblSD.SpanningID, tblSD.VariantID " _
                & "FROM tblSD " _
                & "WHERE (((tblSD.ObjecttypeID)= " & Me.cboObjecttypeID & ") " _
                & "AND ((tblSD.SpanningID)=" & Me.Parent!cboSpanningID & ") " _
                & "AND ((tblSD.VariantID)= " & Me.Parent!cboVariantID & "));"
    
                Set rst = CurrentDb.OpenRecordset(strSQL)
    
                With rst
                    If .RecordCount > 0 Then
                       lngID = ![SD_ID]
                    End If
                    .Close
                End With
                
                Set rst = CurrentDb.OpenRecordset("SELECT * FROM tblSD_Fabrikanttype")
                With rst
                    If .RecordCount > 0 Then
                        .AddNew
                        ![SD_ID] = lngID
                        ![FabrikanttypeID] = Me.cboFabrikanttypeID
                        .Update
                    End If
                    .Close
                End With
        End If
    End If
    
ErrorHandlerExit:
    Exit Sub

ErrorHandler:
    'Indien FabrikanttypeID samen met het andere veld al aanwezig is dan foutmelding afhandeling
    If Err = 3022 Then
        strTitle = "Bestaat al"
        strPrompt = "Fabrikanttype " & Me.cboFabrikanttypeID.Column(1) & "" _
          & " bestaat al in standaard"
        MsgBox Prompt:=strPrompt, _
          buttons:=vbInformation + vbOKOnly, _
          Title:=strTitle
        Resume ErrorHandlerExit
    Else
        MsgBox "Error No: " & Err.Number & "; Description: " & _
        Err.Description
        Resume ErrorHandlerExit
    End If
End Sub
 
Je kunt van de subs een functie maken die je dan aanroept vanaf de verschillende formulieren. Daarbij ga je er dan wel vanuit dat de objecten altijd dezelfde naam hebben. Is dat niet zo, dan moet je de waarden van de verschillende keuzelijsten meegeven als parameter, dan werkt het ook.
Code: 
Function funFabrikantToevoegen(frm As Form)
On Error GoTo ErrorHandler
'Doel gekozen fabrikanttypeID uit werktabel toevoegen aan brontabel waarbij fabrikanttypeID samen
'met een ander veld een unieke index vormen
    'Controleren of in de combo's een geldige waarde uit de lijst gekozen is
    If frm.cboObjecttypeID.ListIndex >= 0 And frm.cboFabrikanttypeID >= 0 Then
        strTitle = "Bronbestand"
        strPrompt = "Fabrikanttype " & frm.cboFabrikanttypeID.Column(1) & " toevoegen aan standaard?"
        intReturn = MsgBox(Prompt:=strPrompt, buttons:=vbQuestion + vbYesNo, Title:=strTitle)
        If intReturn = vbYes Then
            'Opzoeken SD_ID op basis van gegevens in hoofd/subformulier
            strSQL = "SELECT SD_ID, ObjecttypeID, SpanningID, VariantID FROM tblSD " _
                & "WHERE (ObjecttypeID= " & frm.cboObjecttypeID & " AND SpanningID = " _
                & frm.Parent!cboSpanningID & " AND VariantID = " & frm.Parent!cboVariantID & ");"
            Set rst = CurrentDb.OpenRecordset(strSQL)
            With rst
                If .RecordCount > 0 Then
                   lngID = !SD_ID
                End If
                .Close
            End With
            Set rst = CurrentDb.OpenRecordset("tblSD_Fabrikanttype")
            With rst
                .AddNew
                !SD_ID = lngID
                !FabrikanttypeID = frm.cboFabrikanttypeID
                .Update
                .Close
            End With
        End If
    End If
    Exit Function

ErrorHandler:
    'Indien FabrikanttypeID samen met het andere veld al aanwezig is dan foutmelding afhandeling
    If Err = 3022 Then
        strTitle = "Bestaat al"
        strPrompt = "Fabrikanttype " & frm.cboFabrikanttypeID.Column(1) & " bestaat al in standaard"
        MsgBox Prompt:=strPrompt, buttons:=vbInformation + vbOKOnly, Title:=strTitle
    Else
        MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
    End If
End Function

Op de formulieren roep je de functie dan zo aan:
Code: 
     funFabrikantToevoegen Me
 
Hi Octafish,

Er een functie van maken kan ik nog overwegen. De andere objecten hebben wel andere namen dus dan moeten er parameters meegestuurd worden. Ik ben eigenlijk wel benieuwd of code 2 nog kan worden vereenvoudigd (of code 1) door bijvoorbeeld maar één recordset te gebruiken of met bijvoorbeeld een querydef. Zie jij hiertoe mogelijkheden?
 
Zitten er verschillen tussen de 2 codes dan? Ik heb ze (dacht ik tenminste) uitgebreid bekeken, en volgens mij waren ze verder identiek.. Zal ik wel wat gemist hebben :). Op het moment dat je de code op meerdere plekken wilt toepassen, en de objectnamen zijn verschillend, red je het inderdaad niet met deze functie; simpel, omdat je wél nu de naam van het formulier meegeeft, en de (identieke) objecten dus kunt uitlezen. Maar bij afwijkende veld/objectnamen werkt dat dus niet meer. Dat alleen al is een perfecte reden om objectnamen identiek te maken trouwens.... Maar goed, stel dat je dus tóch kiest voor afwijkende objectnamen, dan zul je die velden dus inderdaad als parameter mee moeten geven aan de functie.
Je kan de hele functie uiteraard doen zonder één enkele recordset; het toevoegen van het record kan makkelijk met een toevoegquery, dus zonder recordset, en het opzoeken van de waarde SD_ID kan met DLookup. Ik vermoed zelfs dat de SD_ID al uit het formulier gehaald kan worden.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan