Option Compare Database 'Gebruik databasevolgorde voor tekenreeksvergelijkingen
Option Explicit 'Afdwingen declaratie alle variabelen
Public Function TelRegels(varTeTesten As Variant) As Integer
'-----------------------------------------------------------
' Invoer : Een tekenreeks
' Uitvoer: Integer met het aantal regeleinden (regels)
' in de tekenreeks. Nuttig voor bepalen van het aantal
' regels in een memoveld.
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
Dim intI As Integer, strWerk As String, intTeller As Integer
TelRegels = 0
If VarType(varTeTesten) <> vbString Then Exit Function
strWerk = varTeTesten
Do
intI = InStr(strWerk, Chr$(13))
If intI = 0 Then Exit Do
intTeller = intTeller + 1
strWerk = Mid(strWerk, intI + 1)
Loop
TelRegels = intTeller
End Function
Public Function TelWoorden(varTeTesten As Variant) As Integer
'-----------------------------------------------------------
' Invoer : Een tekenreeks
' Uitvoer: Integer met het aantal woorden in de tekenreeks.
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
Dim intI As Integer, strWerk As String, intTeller As Integer
TelWoorden = 0
If VarType(varTeTesten) <> vbString Then Exit Function
strWerk = Trim(varTeTesten)
If Len(strWerk) > 0 Then
' Begint bij 1 als de tekenreeks niet leeg is
' -- past zich aan als geen afsluitende spatie
intTeller = 1
Else
intTeller = 0
End If
Do
' Zoek de volgende spatie (einde van woord)
intI = InStr(strWerk, " ")
If intI = 0 Then Exit Do
intTeller = intTeller + 1
' Verklein de tekenreeks tot de volgende niet-spatie
strWerk = Trim(Mid(strWerk, intI + 1))
Loop
TelWoorden = intTeller
End Function
Public Sub FoutenLogboek(strProc As String, ByVal lngErr As Long, ByVal strFout As String)
'-----------------------------------------------------------
' Invoer : Naam van de procedure die de fout afhandeld
' Foutwaarde
' Fouttekst
' Uitvoer: Voegt een rij aan de tabel FoutenLogboek toe
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
Dim db As Database
Dim rstE As Recordset
Dim strFrmNaam As String
Dim strCtlName As String
Dim lngFoutBewaar As Long
Dim strFoutBewaar As String
On Error Resume Next
lngFoutBewaar = lngErr
strFoutBewaar = strFout
Set db = CurrentDb()
Set rstE = db.OpenRecordset("FoutenLogboek")
rstE.AddNew
strFrmNaam = Screen.ActiveForm.Name
rstE!HuidigFormulier = strFrmNaam
' Extra contrle om fout door leeg scherm te voorkomen
If Not IsNothing(strFrmNaam) Then
strCtlName = Screen.ActiveControl.Name
End If
rstE!HuidigBesturingselement = strCtlName
rstE!ActiefFormulier = Forms.Count
rstE!GebruikersNaam = CurrentUser
rstE!Datum = Now
rstE!AanroependeProcedure = strProc
rstE!Foutcode = lngFoutBewaar
rstE!Foutmelding = strFoutBewaar
rstE.Update
rstE.Close
End Sub
Public Function ExtractEmail(ByVal strEmail As String) As String
'-----------------------------------------------------------
' Invoer : E-mailhyperlink-tekenreeks
' Uitvoer: Uit tekenreeks gehaalde e-mailadres
' Levert originele tekenreeks als e-mailadres niet
' gevonden kan worden
' Gemaakt Door : JLV 04/13/2003
' Laatst Gewijzigd: JLV 04/13/2003
'-----------------------------------------------------------
Dim intI As Integer, intJ As Integer
' Probeer "mailto:" te vinden
intI = InStr(strEmail, "mailto:")
' Als niet gevonden, dan verlaten
If intI = 0 Then
ExtractEmail = strEmail
Exit Function
End If
' Zoek nu naar afsluitende "#"
intJ = InStr(intI, strEmail, "#")
' Als niet gevonden, dan naar einde verwijzen
If intJ = 0 Then intJ = Len(strEmail) + 1
' E-mailadres extraheren en teruggeven
ExtractEmail = Mid(strEmail, intI + 7, intJ - intI - 7)
End Function
Private Function HaalSoundexCode(strTeken As String) As String
'-----------------------------------------------------------
' Invoer : Een teken
' Uitvoer: U.S. National archive "Soundex"-nummer
' voor de opgegeven letter
' Gemaakt Door : JLV 03/01/2003
' Laatst Gewijzigd: JLV 03/01/2003
'-----------------------------------------------------------
Select Case strTeken
Case "B", "F", "P", "V"
HaalSoundexCode = "1"
Case "C", "G", "J", "K", "Q", "S", "X", "Z"
HaalSoundexCode = "2"
Case "D", "T"
HaalSoundexCode = "3"
Case "L"
HaalSoundexCode = "4"
Case "M", "N"
HaalSoundexCode = "5"
Case "R"
HaalSoundexCode = "6"
End Select
End Function
Public Function IsFormulierGeladen(ByVal strFormulierNaam As String) As Integer
'-----------------------------------------------------------
' Invoer : Naam van het te testen formulier
' Uitvoer: Waar = formulier is in Forms-verzameling;
' Onwaar = niet in Forms-verzameling
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
On Error GoTo IsFormulierGeladen_Err
IsFormulierGeladen = (SysCmd(acSysCmdGetObjectState, acForm, strFormulierNaam) <> 0)
IsFormulierGeladen_Exit:
On Error GoTo 0
Exit Function
IsFormulierGeladen_Err:
IsFormulierGeladen = False
Err.Clear
Resume IsFormulierGeladen_Exit
End Function
Public Function IsSchrikkeljaar(intJaar As Integer) As Integer
'-----------------------------------------------------------
' Invoer : Een jaar om te testen of het een schrikkeljaar is
' Uitvoer: Waar = Jaar is schrikkeljaar; Onwaar: geen schrikkeljaar
' Gemaakt Door : JLV 01/08/2002
' Laatst Gewijzigd: JLV 01/08/2002
'-----------------------------------------------------------
' Stel foutafhandeling in
On Error GoTo Bail
' Standaardresultaat is Onwaar
IsSchrikkeljaar = False
' Bepaal dag voor datum 29 februari
' Is deze dag nog steeds 29, dan is het een schrikkeljaar
' (Functie DateSerial geef anders 1 maart als resultaat)
If 29 = Day(DateSerial(intJaar, 2, 29)) Then
' Gevonden, antwoord is Waar
IsSchrikkeljaar = True
End If
Klaar:
Exit Function
Bail:
' Eenvoudige code die geen fouten op zou mogen leveren,
' maar voor de zekerheid toch netjes verlaten
Resume Klaar
End Function
Public Function IsNothing(ByVal varValueToTest) As Integer
'-----------------------------------------------------------
' Kijkt of variabele gebaseerd op het gegevenstype leeg is
' Null = leeg
' Empty = leeg
' Nummer = 0 is leeg
' Tekenreeks = "" is leeg
' Datum/tijd is nooit leeg
' Invoer : Een waarde die op logisch 'leeg' moet worden getest
' Uitvoer: Waar = waarde is logisch 'leeg'; Onwaar: is niet 'leeg'
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
Dim intSuccess As Integer
On Error GoTo IsNothing_Err
IsNothing = True
Select Case VarType(varValueToTest)
Case 0 ' Leeg
GoTo IsNothing_Exit
Case 1 ' Null
GoTo IsNothing_Exit
Case 2, 3, 4, 5, 6 ' Integer, Lang, Enkel, Dubbel, Valuta
If varValueToTest <> 0 Then IsNothing = False
Case 7 ' Datum/tijd
IsNothing = False
Case 8 ' Tekenreeks
If (Len(varValueToTest) <> 0 And varValueToTest <> " ") Then IsNothing = False
End Select
IsNothing_Exit:
On Error GoTo 0
Exit Function
IsNothing_Err:
IsNothing = True
Resume IsNothing_Exit
End Function
Public Function IsTabel(ByVal strTabelNaam) As Integer
'-----------------------------------------------------------
' Invoer : Naam die gecontroleerd moet worden of het tabel is
' Uitvoer: Waar = naam is een tabelobject; Onwaar = geen tabelobject
' Gemaakt Door : JLV 01/31/95
' Laatst Gewijzigd: JLV 01/31/95
'-----------------------------------------------------------
Dim intSuccess As Integer
Dim dbCurr As Database, intI As Integer, tdf As TableDef
On Error GoTo IsTabel_Err
IsTabel = True
Set dbCurr = CurrentDb
Set tdf = dbCurr(strTabelNaam)
IsTabel_Exit:
On Error GoTo 0
Exit Function
IsTabel_Err:
IsTabel = False
Resume IsTabel_Exit
End Function
Public Function Parse(strIn As String, Optional intPart As Integer, Optional strTeken As String) As String
'-----------------------------------------------------------
' Invoer : Tekenreeks om te verwerken, gewenste deel, scheidingsteken
' Uitvoer: Het 'n-de' deel of 'hap' van de tekenreeks
' Gemaakt Door : JLV 01/13/2003
' Laatst Gewijzigd: JLV 01/13/2003
'-----------------------------------------------------------
' strIn - de te verwerken tekenreeks
' intPart - het gezochte deel; standaardwaarde is 1 als u niets opgeeft
' strTeken - het scheidingsteken; standaardwaarde is een spatie als u niets opgeeft
Dim strWerk As String, strC As String
Dim intOffset1 As Integer, intOffset2 As Integer
Dim intStart As Integer, intP As Integer, intI As Integer
' Standaarddeel is 1
intP = 1
' Controleer of parameter is opgegeven
If Not IsMissing(intPart) Then
' Moet groter zijn dan 0; gebruik anders 1
If intPart > 0 Then intP = intPart
End If
' Standaardscheidingsteken is spatie
strC = " "
' Controleer of parameter is opgegeven
If Not IsMissing(strTeken) Then
' Gebruik eerste teken als meerdere tekens opgegeven
If Len(strTeken) > 0 Then strC = Left(strTeken, 1)
End If
' Elke doorloop zoekt opnieuw naar het teken,
' te beginnen bij de laatste positie +1
For intI = 1 To intP
intOffset2 = InStr(intOffset1 + 1, strIn, strC)
If intOffset2 = 0 Then Exit For
' Sla de huidige startpositie op
intStart = intOffset1
' Bereken de startpositie voor de volgende zoekronde
intOffset1 = intOffset2
Next intI
' Als startpositie 0 is,
' dan bestaat het zoekteken niet of er zijn
' geen "intPart" delen
If intOffset2 = 0 Then Exit Function
' Lever het antwoord terug
Parse = Mid(strIn, intStart + 1, intOffset2 - intStart - 1)
End Function
Function ParseDatums(strIn As String, datVan As Date, datTot As Date) As Integer
'-----------------------------------------------------------
' Invoer : Een filtertekenreeks met 'van' en 'tot' datums
' Uitvoer: Tot twee gevonden datums worden in de twee parameters teruggegeven
' Gemaakt Door : JLV 02/18/02
' Laatst Gewijzigd: JLV 02/18/02
'-----------------------------------------------------------
Dim strWerk As String, intI As Integer, strDatum As String
strWerk = strIn
' Zoek eerste scheidingsteken
intI = InStr(strWerk, "#")
' Niet gevonden - verlaten
If intI = 0 Then Exit Function
' Wis alles tot aan het scheidingsteken
strWerk = Mid(strWerk, intI + 1)
' Zoek het volgende scheidingsteken
intI = InStr(strWerk, "#")
' Niet gevonden - verlaten
If intI = 0 Then Exit Function
' Sla datgene waarvan we denken dat het een datum is,
' op in een testvariabele
strDatum = Left(strWerk, intI - 1)
' Controleer of het een datum is
If Not IsDate(strDatum) Then Exit Function
' Datum gevonden - toewijzen
datVan = DateValue(strDatum)
' Haal wat we zojuist hebben gevonden weg
strWerk = Mid(strWerk, intI + 1)
' Zoek het volgende scheidingsteken
intI = InStr(strWerk, "#")
' Niet gevonden - verlaten
If intI = 0 Then Exit Function
' Verwijder tot aan het scheidingsteken
strWerk = Mid(strWerk, intI + 1)
' Zoek het laatste scheidingsteken
intI = InStr(strWerk, "#")
' Niet gevonden - klaar
If intI = 0 Then Exit Function
' Opslaan in testvariabele
strDatum = Left(strWerk, intI - 1)
' Controleer of het een datum is
If Not IsDate(strDatum) Then Exit Function
' Ga naar de tweede!
datTot = DateValue(strDatum)
ParseDatums = True
End Function
Function ParseVoornaam(strNaam As String) As Variant
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van een persoon: Achternaam, Voornaam Tussenletters. (Achtervoegsel)
' Uitvoer: De voornaam als tekenreeks
' Comment: Dit is een envelopfunctie voor ParseNaam die vanuit
' query aangeroepen kan worden om alleen de voornaam te bepalen
' Gemaakt Door : JLV 12/11/02
' Laatst Gewijzigd: JLV 12/11/02
'-----------------------------------------------------------
Dim strAchternaam As String, varFirst As Variant, varMiddle As Variant, varSuffix As Variant
' Standaardresultaatwaarde Null
ParseVoornaam = Null
' Aanroepen ParseNaam - is geldig resultaat, dan gezochte deel teruggeven
If ParseNaam(strNaam, strAchternaam, varFirst, varMiddle, varSuffix) Then
ParseVoornaam = varFirst
End If
End Function
Function ParseAchternaam(strNaam As String) As String
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van een persoon: Achternaam, Voornaam Tussenletters. (Achtervoegsel)
' Uitvoer: De achternaam als tekenreeks
' Comment: Dit is een envelopfunctie voor ParseNaam die vanuit
' query aangeroepen kan worden om alleen de achternaam te bepalen
' Gemaakt Door : JLV 12/11/02
' Laatst Gewijzigd: JLV 12/11/02
'-----------------------------------------------------------
Dim strAchternaam As String, varFirst As Variant, varMiddle As Variant, varSuffix As Variant
' Aanroepen ParseNaam - is geldig resultaat, dan gezochte deel teruggeven
If ParseNaam(strNaam, strAchternaam, varFirst, varMiddle, varSuffix) Then
ParseAchternaam = strAchternaam
End If
End Function
Function ParseTussenvoegsel(strNaam As String) As Variant
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van een persoon: Achternaam, Voornaam Tussenletters. (Achtervoegsel)
' Uitvoer: De tussenletters als tekenreeks
' Comment: Dit is een envelopfunctie voor ParseNaam die vanuit
' query aangeroepen kan worden om alleen de tussenletters te bepalen
' Gemaakt Door : JLV 12/11/02
' Laatst Gewijzigd: JLV 12/11/02
'-----------------------------------------------------------
Dim strAchternaam As String, varFirst As Variant, varMiddle As Variant, varSuffix As Variant
' Standaardresultaatwaarde Null
ParseTussenvoegsel = Null
' Aanroepen ParseNaam - is geldig resultaat, dan gezochte deel teruggeven
If ParseNaam(strNaam, strAchternaam, varFirst, varMiddle, varSuffix) Then
ParseTussenvoegsel = varMiddle
End If
End Function
Function ParseNaam(strNaam As String, strAchternaam As String, varFirst As Variant, _
varMiddle As Variant, varSuffix As Variant) As Integer
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van een persoon: Achternaam, Voornaam Tussenletters. (Achtervoegsel)
' Uitvoer: De bouwstenen van de naam als losse tekenreeksen
' Gemaakt Door : JLV 12/11/02
' Laatst Gewijzigd: JLV 12/11/02
'-----------------------------------------------------------
Dim strWerk As String, intI As Integer
' Standaardresultaatwaarde Null (Niet leeg/empty)
varFirst = Null
varMiddle = Null
varSuffix = Null
' Verplaats de invoer naar de werktekenreeks
strWerk = Trim(strNaam)
' Zoek eerst het einde van de achternaam
intI = InStr(strWerk, ",")
' Als niet gevonden, lever dan de hele tekenreeks in strAchternaam en verlaten
If intI = 0 Then
strAchternaam = strWerk
ParseNaam = False
Exit Function
End If
' Wis de achternaam
strAchternaam = Left(strWerk, intI - 1)
strWerk = Trim(Mid(strWerk, intI + 1))
' Controleer vervolgens of er een achtervoegsel is
intI = InStr(strWerk, "(")
If intI <> 0 Then
' Achtervoegsel gevonden; opslaan en wissen
varSuffix = Mid(strWerk, intI + 1, Len(strWerk) - intI - 1)
strWerk = Trim(Left(strWerk, intI - 1))
End If
' Is het laatste teken nu een punt?
If Right(strWerk, 1) = "." Then
' Ja, aannemen dat het de tussenletters zijn
varMiddle = Mid(strWerk, Len(strWerk) - 1, 1)
strWerk = Trim(Left(strWerk, Len(strWerk) - 2))
End If
' Neem aan dat de rest de voornaam is
If Len(strWerk) > 0 Then varFirst = strWerk
ParseNaam = True
End Function
Function ParseAchtervoegsel(strNaam As String) As Variant
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van een persoon: Achternaam, Voornaam Tussenletters. (Achtervoegsel)
' Uitvoer: Het achtervoegsel als tekenreeks
' Comment: Dit is een envelopfunctie voor ParseNaam die vanuit
' query aangeroepen kan worden om alleen het achtervoegsel te bepalen
' Gemaakt Door : JLV 12/11/02
' Laatst Gewijzigd: JLV 12/11/02
'-----------------------------------------------------------
Dim strAchternaam As String, varFirst As Variant, varMiddle As Variant, varSuffix As Variant
' Standaardwaarde Null
ParseAchtervoegsel = Null
' Aanroepen ParseNaam - is geldig resultaat, dan gezochte deel teruggeven
If ParseNaam(strNaam, strAchternaam, varFirst, varMiddle, varSuffix) Then
ParseAchtervoegsel = varSuffix
End If
End Function
Function SaveRecord() As Variant
'-----------------------------------------------------------
' Aangeroepen vanuit een eigen menu of werkbalk om het record
' op te slaan. Zoekt de publieke procedure cmdSave_Click in
' het actieve formulier en voert deze uit door deze procdure
' van dit formulier aan te roepen. Is er geen actief formulier
' dan wordt de functie gesloten.
' Gemaakt Door : JLV 06/09/03
' Laatst Gewijzigd: JLV 06/09/03
'----------------------------------------------------------
' Toevoegen om huidige actieve formulier op te slaan
Dim frm As Form
' Sla alle fouten over
On Error Resume Next
' Probeer het active formulier te bepalen
Set frm = Screen.ActiveForm
' Als fout, dan verlaten
If Err <> 0 Then Exit Function
' Probeer nu de procedure voor het opslaan aan te roepen
frm.cmdSave_Click
' Klaar
Err.Clear
End Function
Function SetUpper(ByVal strFixCase As Variant) As Variant
'-----------------------------------------------------------
' Invoer : Een tekenreeks met de naam van de persoon
' Uitvoer: Stelt de hoofdletters voor de naam in
' Gemaakt Door : JLV 07/31/98
' Laatst Gewijzigd: JLV 07/31/98
'-----------------------------------------------------------
Dim i As Integer
Dim intSkip As Integer
Dim intASC As Integer
Dim strHoofdletter As String
Dim strLaatste As String
If VarType(strFixCase) <> 8 Then
SetUpper = Null
Exit Function
End If
strHoofdletter = strFixCase
strLaatste = " " ' Stel het uitgangsteken voor de achternaam in op een spatie
' Wijzig allereerst alles in onderkast
strHoofdletter = LCase$(strHoofdletter)
' Lus door alle tekens, 1 teken per keer
For i = 1 To Len(strHoofdletter)
' Controleer allereerst of we letters overslaan (speciale gevallen)
If intSkip > 0 Then
intSkip = intSkip - 1 ' Ja. Verlaag teller
GoTo NextOne ' en doe volgende teken
End If
' Als 'laaste' teken een spatie of het begin van een tekenreeks was,
' controleer dan op de speciale gevallen "O'", "Mc", and "Mac"
If strLaatste = " " Then
If Len(strHoofdletter) - i > 2 Then ' Als ten minste 3 tekens over,
' dan als de volgende 2 O' (als in O'Brien) of Mc (als in McDonald) zijn
If Mid$(strHoofdletter, i, 2) = "o'" Or Mid$(strHoofdletter, i, 2) = "mc" Then
' Maak van de "O" of "M" hoofdletters
Mid$(strHoofdletter, i, 1) = UCase$(Mid$(strHoofdletter, i, 1))
intSkip = 1 ' en verhoog teller mt 1
GoTo NextOne ' en verwerk volgende teken.
End If
' Zijn de volgende 3 Mac (als in MacDougal)
If Mid$(strHoofdletter, i, 3) = "mac" Then
' maak dan van de "M" een hoofdletter
Mid$(strHoofdletter, i, 1) = UCase$(Mid$(strHoofdletter, i, 1))
intSkip = 2 ' en verhoog teller met 2
GoTo NextOne ' en verwerk volgende teken.
End If
End If
End If
' Geen speciaal geval, dus controleren of laatste teken een letter of een apostrof is
intASC = Asc(strLaatste) ' Gebruik de ASCII-waarde om de controle te vereenvoudigen
If intASC = 39 Or (intASC >= 97 And intASC <= 122) Or (intASC >= 65 And intASC <= 90) Or (intASC >= 224 And intASC <= 246) Or (intASC >= 248) Then
' Was het vorige teken een letter of apostrof, dan dit teken met rust laten
Else
' Was het vorige teken GEEN letter of apostrof, dan er een hoofdletter van maken
Mid$(strHoofdletter, i, 1) = UCase$(Mid$(strHoofdletter, i, 1))
End If
strLaatste = Mid$(strHoofdletter, i, 1) ' Teken opslaan voor de volgende ronde
NextOne:
Next i
SetUpper = strHoofdletter
End Function
Function Soundex(strNaam As String) As String
'-----------------------------------------------------------
' Invoer : Een tekenreeks
' Uitvoer: U.S. National archive "Soundex"-nummer
' Aan de hand van dit nummer kunnen gelijkklinkende
' achternamen worden gevonden.
' Gemaakt Door : JLV 03/01/2003
' Laatst Gewijzigd: JLV 03/01/2003
'-----------------------------------------------------------
' Een soundex-code bestaat uit de eerste letter gevolgd door
' drie cijfers afgeleid uit de evaluatie van de overige letters.
' Klinkers worden genegeerd. Leveren opeenvolgende letters
' dezelfde numerieke waarde, dan verschijnt deze waarde maar
' één keer. Letters worden als volgt naar nummers vertaald:
' B, P, F, V = 1
' C, S, G, J, K, Q, X, Z = 2
' D, T = 3
' L = 4
' M, N = 5
' R = 6
' Is de uiteindelijke code na evaluatie van alle letters minder
' dan drie tekens lang, dan wordt deze aangevuld met nullen.
' Werkvariabelen
' Tekenreeks om de code op te bouwen en tekenreeks om codenummer te bewaren
Dim strCode As String, strCodeN As String
' Lengte van de originele tekenreeks, laatste geleverde code en lusinteger
Dim intLength As Integer, strLaatsteCode As String, intI As Integer
' Sla de eerste letter op
strCode = UCase(Left(strNaam, 1))
' Sla zijn codenummer op om op duplicaten te controleren
strLaatsteCode = HaalSoundexCode(strCode)
' Bereken de lengte voor de evaluatie
intLength = Len(strNaam)
' Creëer de code te beginnen met de tweede letter
For intI = 2 To intLength
strCodeN = HaalSoundexCode(Mid(strNaam, intI, 1))
' Als twee gelijke letters naast elkaar staan,
' dan wordt er maar één geteld
If Len(strCodeN) > 0 And strLaatsteCode <> strCodeN Then
' Ander codenummer, toevoegen aan resultaat
strCode = strCode & strCodeN
End If
' Sla het laatste codenummer op
strLaatsteCode = strCodeN
' Lus
Next intI
' Controleer de lengte
If Len(strCode) < 4 Then
' Opvullen met nullen
strCode = strCode & String(4 - Len(strCode), "0")
Else
' Zorg dat het totaal niet meer dan vier tekens lang is
strCode = Left(strCode, 4)
End If
' Lever het resultaat terug
Soundex = strCode
End Function
