MS Access. - Module.
- Zilvermeeuw-16
- Access start
- Datum functies
- Mappen Bestanden
- String functies
- Scripting runtime
- HTML aanmaken
- Groupwise
- Allerlei routines
- Nederlandstalige dag
- Leeftijd
- Valt een geboortedatum
- Laatste dag huidige maand
- Laatste dag vorige maand
- Varianten datum functies
Functie die Nederlandstalige weekdag weergeeft
'Datum ingeven in de vorm #dd/mm/jjjj#
Public Function f_Weekdag(datDatum As Date) As String
Dim bytdag As Byte
datDatum = Format(datDatum, "mm,dd,yyyy")
Debug.Print Month(datDatum)
bytdag = WeekDay(datDatum)
Select Case bytdag
Case 1: f_Weekdag = "Zondag"
Case 2: f_Weekdag = "Maandag"
Case 3: f_Weekdag = "Dinsdag"
Case 4: f_Weekdag = "Woensdag"
Case 5: f_Weekdag = "Donderdag"
Case 6: f_Weekdag = "Vrijdag"
Case 7: f_Weekdag = "Zaterdag"
End Select
End Function
Op basis van de geboortedatum wordt de
leeftijd weergegeven
in jaren, maanden, dagen.
' gebruik : av_Leeftijd(#01/04/1960#)
Function av_Leeftijd(datGeboorte As Date) As String
Dim datNu As Date
Dim datDum As Date
Dim intJaar As Integer
Dim intJaarDum As Integer
Dim intMaand As Integer
Dim intMaandDum As Integer
Dim intDag As Integer
datNu = DateSerial(Year(Date), Month(Date), Day(Date))
datNu = Format(datNu, "DD/MM/YYYY")
datGeboorte = DateSerial(Year(datGeboorte), Month(datGeboorte),
Day(datGeboorte))
datGeboorte = Format(datGeboorte, "MM/DD/YYYY")
intJaar = Year(datNu) - Year(datGeboorte)
If Month(datNu) < Month(datGeboorte) Then
intJaar = intJaar - 1
intMaand = 12 - (Month(datGeboorte) - Month(datNu))
If Day(datNu) < Day(datGeboorte) Then
intMaand = intMaand - 1
If Month(datNu) = 1 Then
intMaandDum = 12
intJaarDum = Year(datNu) - 1
Else
intMaandDum = Month(datNu) - 1
intJaarDum = Year(datNu)
End If
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
If Day(datNu) > Day(datGeboorte) Then
intMaandDum = Month(datNu)
intJaarDum = Year(datNu)
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
End If
If Month(datNu) = Month(datGeboorte) Then
If Day(datNu) < Day(datGeboorte) Then
intMaand = 11
If Month(datNu) = 1 Then
intMaandDum = 12
intJaarDum = Year(datNu) - 1
Else
intMaandDum = Month(datNu) - 1
intJaarDum = Year(datNu)
End If
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
If Day(datNu) > Day(datGeboorte) Then
intMaandDum = Month(datNu)
intJaarDum = Year(datNu)
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
End If
If Month(datNu) > Month(datGeboorte) Then
intMaand = Month(datNu) - Month(datGeboorte)
If Day(datNu) < Day(datGeboorte) Then
intMaand = intMaand - 1
If Month(datNu) = 1 Then
intMaandDum = 12
intJaarDum = Year(datNu) - 1
Else
intMaandDum = Month(datNu) - 1
intJaarDum = Year(datNu)
End If
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
If Day(datNu) > Day(datGeboorte) Then
intMaandDum = Month(datNu)
intJaarDum = Year(datNu)
datDum = DateSerial(intJaarDum, intMaandDum, Day(datGeboorte))
datDum = Format(datDum, "DD/MM/YYYY")
intDag = DateDiff("d", datDum, datNu)
End If
End If
av_Leeftijd = intJaar & " jaar " & intMaand & " maand " & intDag & " dagen "
End Function
Valt een geboortedatum tussen twee data
'gebruik : GebDat(#15/01/1973#,#31/12/1995#,#11/07/1985#)
Public Function GebDat(datStart As Date, datEind As Date, datGeb As Date) As
Boolean
Dim bytStartMnd As Byte
Dim bytStartDg As Byte
Dim bytEindMnd As Byte
Dim bytEindDg As Byte
Dim bytGebMnd As Byte
Dim bytGebDg As Byte
bytStartMnd = Month(datStart)
bytStartDg = Day(datStart)
bytEindMnd = Month(datEind)
bytEindDg = Day(datEind)
bytGebMnd = Month(datGeb)
bytGebDg = Day(datGeb)
If bytGebMnd >= bytStartMnd And bytGebMnd <= bytEindMnd Then
If bytGebDg >= bytStartDg And bytGebDg <= bytEindDg Then
GebDat = True
Else
GebDat = False
End If
Else
GebDat = False
End If
End Function
Wat is de laatste dag van de huidige maand ?
Public Function fLtsteDagNuMnd As Date
fLtsteDagNuMnd = Format(DateSerial(Year(date),Month(date)+1,0),"dd/mm/yyyy")
End Function
Wat is de laatste dag van de vorige maand ?
Public Function fLtsteDagVorigMnd As Date
fLtsteDagVorigMnd = Format(DateSerial(Year(date),Month(date),0),"dd/mm/yyyy")
End Function
Varianten op de ingebouwde
Year, Month en Day Functies
Access kan met ingebouwde datum-functies soms onverwachte resultaten opleveren
'Dit omdat Access standaard uitgaat van de datum vorm mm/dd/jjjj
'Alhoewel niet noodzakelijk voor het jaartal, maar des te meer voor maand en dag
'toch voor jaartal, omwille van consistentie toch deze Functie
Public Function fJaar(datDatum As Date) As Integer
datDatum = Format(datDatum, "mm/dd/yyyy")
fJaar = Year(datDatum)
End Function
de ingebouwde VBA functie Month kan onverwachte resultaten leveren
indien in de dd/mm/jjjj aanduiding de dag kleiner dan of gelijk is aan 12
bijvoorbeeld Month(#07/12/2011#) geeft als resultaat 7 waar het 12 moet zijn
Public Function fMaand(datDatum As Date) As Integer
datDatum = Format(datDatum, "mm/dd/yyyy")
fMaand = Month(datDatum)
End Function
ook de ingebouwde VBA functie Day kan onverwachte resultaten leveren
indien in de dd/mm/jjjj aanduiding de dag kleiner dan of gelijk is aan 12
Public Function fDag(datDatum As Date) As Integer
datDatum = Format(datDatum, "mm/dd/yyyy")
fDag = Day(datDatum)
End Function
Map huidige database.
Public Function bb_f_MapDB() As String
'Functie geeft de directory van de huidige Database
On Error GoTo FoutBehandeling
bb_f_MapDB = Application.CurrentProject.Path
Verlaten:
Exit Function
FoutBehandeling:
MsgBox Err.Number & " " & Err.Description, vbOKOnly +
vbCritical, "Fout in bb_f_MapDB"
Resume Verlaten
End Function
Map huidige database van Kenneth S Courtney.
Public Function GetDirectory()
'Functie geeft de directory van de huidige Database
'Afkomstig van Kenneth S Courtney
Dim strDir As String
Dim strDbNaam As String
Dim strTotDbNaam As String
strDir = CurrentDb().Name
strTotDbNaam = CurrentDb().Name
Do Until Right(strDir, 1) = "\"
strDir = Left(strDir, Len(strDir) - 1)
Loop
ChDir strDir
strDbNaam = Right(strTotDbNaam, Len(strTotDbNaam) - Len(strDir))
GetDirectory = strDir
End Function
Pad en Naam huidige database
Public Function bb_f_MapNaamDB() As String
'Functie geeft volledig pad en naam huidige database
On Error GoTo FoutBehandeling
bb_f_MapNaamDB = Application.CurrentProject.Path & "\" & Application.CurrentProject.Name
Verlaten:
Exit Function
FoutBehandeling:
MsgBox Err.Number & " " & Err.Description, vbOKOnly + vbCritical, "Fout in bb_f_MapNaamDB"
Resume Verlaten
End Function
Begin
Interessante String functies
Deze handige functies zijn afkomstig van
Peter Debaets
Ik heb deze functies al zeer veel toegepast
Function xg_lPad(sStringToPad As String, sPadChar As String, iTotalDesiredLengthOfString As Integer) As String
'bepaalde string links opvullen met een ander string-karakter tot een
'vooraf bepaalde lengte
'voorbeeld xg_lPad("aa","b",10) geeft bbbbbbbbaa
xg_lPad = xg_Repeat(sPadChar, iTotalDesiredLengthOfString -
Len(Trim(sStringToPad))) & Trim(sStringToPad)
End Function
+ + + + + + + + + + + +
Function xg_RPad(sStringToPad As String, sPadChar As String, iTotalDesiredLengthOfString As Integer) As String
'een bepaalde string opvullen met een ander string-karakter tot een
'vooraf bepaalde lengte
'voorbeeld xg_RPad("aa","b",10) geeft aabbbbbbbb
Dim i As Integer
Dim sFill As String
sFill = ""
If Len(sStringToPad) < iTotalDesiredLengthOfString Then
For i = 1 To (iTotalDesiredLengthOfString -
Len(sStringToPad))
sFill = sFill & sPadChar
Next i
End If xg_RPad = sStringToPad & sFill
End Function
+ + + + + + + + + + + +
Function xg_Repeat(sStringToRepeat As String, iNumOfTimes As Integer) As String
'herhaalt een bepaald keer een string
'bijvoorbeeld xg_Repeat("ai ",10) geeft
'ai ai ai ai ai ai ai ai ai ai
Dim i As Integer
Dim s As String
s = ""
For i = 1 To iNumOfTimes
s = s & sStringToRepeat
Next i
xg_Repeat = s
End Function
+ + + + + + + + + + + +
Function xg_ReplaceAllWith(sMainString As String, _
sSubString As String, sReplaceString As String) As String
'repeterende functie die in een hoofdstring=sMainString, de aangegeven substring
'vervangt door een vervangstring=sReplaceString
'voorbeeld ? xg_ReplaceAllWith("+32498-25-10-25","-","/")
'geeft +32498/25/10/25
Dim i As Integer
Dim ipos As Integer
Dim s As String
Dim s1 As String, s2 As String
s = sMainString
ipos = InStr(1, sMainString, sSubString)
If ipos = 0 Then
GoTo Exit_xg_ReplaceAllWith
End If
s1 = Mid(sMainString, 1, ipos - 1)
s2 = Mid(sMainString, ipos + Len(sSubString), Len(sMainString))
s = s1 & sReplaceString & _
xg_ReplaceAllWith(s2, sSubString, sReplaceString)
Exit_xg_ReplaceAllWith:
xg_ReplaceAllWith = s
End Function
+ + + + + + + + + + + +
Function xg_GetWordsBetween(sMain As String, s1 As String, s2 As String) As String
'geeft een getrimde substring van sMain die ligt tussen de substrings s1 en s2
'bijvoorbeeld ? xg_GetWordsBetween("het is vandaag mooi weer","is","weer")
'geeft vandaag mooi
On Error Resume Next
Dim iStart As Integer, iEnd As Integer
iStart = InStr(1, sMain, s1) + Len(s1)
iEnd = InStr(iStart, sMain, s2)
xg_GetWordsBetween = Trim(Mid(sMain, iStart, iEnd -
iStart))
End Function
+ + + + + + + + + + + +
Function xg_GetLastWord(sStr As String) As String
'geeft het laatste woord van een string terug
'vb xg_GetLastWord("vandaag wordt het een mooie dag") geeft dag
Dim i As Integer
Dim ilen As Integer
Dim s As String
Dim stemp As String
Dim sLastWord As String
Dim sHold As String
Dim iFoundChar As Integer
stemp = ""
sLastWord = ""
iFoundChar = False
sHold = sStr
ilen = Len(sStr)
For i = ilen To 1 Step -1
s = Right(sHold, 1)
If s = " " Then
If Not iFoundChar Then
'* skip spaces at end of string.
Else
sLastWord = stemp
Exit For
End If
Else
iFoundChar = True
stemp = s & stemp
End If
If Len(sHold) > 0 Then
sHold = Left(sHold, Len(sHold) - 1)
End If
Next i
If sLastWord = "" And stemp <> "" Then
sLastWord = stemp
End If
'MsgBox "lastword =" & Trim(sLastWord)
xg_GetLastWord = Trim(sLastWord)
End Function
+ + + + + + + + + + + +
Function xg_GetSubString(mainstr As String, n As Integer, delimiter As String) As String
'geeft de n-de substring van een reeks gescheiden door een scheidingsteken
''vb xg_GetSubString("een|twee|drie|vier|vijf",3,"|") geeft drie
Dim i As Integer
Dim substringcount As Integer
Dim pos As Integer
Dim strx As String
Dim val1 As Integer
Dim w As String
On Error GoTo Err_xg_GetSubString
w = ""
substringcount = 0
i = 1
pos = InStr(i, mainstr, delimiter)
Do While pos <> 0
strx = Mid(mainstr, i, pos - i)
substringcount = substringcount + 1
If substringcount = n Then
Exit Do
End If
i = pos + 1
pos = InStr(i, mainstr, delimiter)
Loop
If substringcount = n Then
xg_GetSubString = strx
Else
strx = Mid(mainstr, i, Len(mainstr) + 1 - i)
substringcount = substringcount + 1
If substringcount = n Then
xg_GetSubString = strx
Else
xg_GetSubString = ""
End If
End If
Exit Function
Err_xg_GetSubString:
MsgBox "xg_GetSubString " & Err & " " & Err.Description
Resume Next
End Function
- Wat is scripting runtime
- Het Dictionary object.
- Het Filesystem object.
- Drives.
- Submappen.
- Bestanden.
- Bestaat een submap.
- Methodes.
- Tekstbestand.
- Tekst toevoegen.
- Lezen tekstbestand.
Wat is het Microsoft Scripting Runtime object ?
Wanneer men Office installeert is het Microsoft Scripting Runtime object één van de beschikbare bibliotheken (libraries).
Met dit object is het mogelijk schijven, mapppen en bestanden te benaderen. Bovendien kan men op een eenvoudige wijze schrijven en
lezen naar en van tekstbestanden.
Om in MS Access gebruik te maken van het Scripting Runtime object moet men in de Visual basic editor via het Menu -> Tools -> References
een referentie maken naar het object.
Op het top-niveau van de Scripting Runtime object heeft men twee objecten :
- het Dictionary-
- en het FileSystemObject.
Persoonlijk heb ik tot op heden practisch enkel gebruik gemaakt van het FileSystemObject.
Het Dictionary object.
Het Dictionary object is voor een stuk gelijkaardig aan het VBA Collection object, alsook aan Arrays (reeksen). Maar anderzijds
heeft het Dictionary object kenmerken die men bij de andere niet beschikbaar zijn.
Het is een datastructuur die uit paren bestaat van
- een item die eender welk datatype kan hebben
- en een unieke sleutelwaarde.
Dim dctDict As Dictionary
Set dctDict = New Dictionary
dctDict.CompareMode = BinaryCompare
dctDict.Add 1, "het eerste item"
dctDict.Add 2, "het tweede item"
dctDict.Add 3, "het derde item"
dctDict.Add 4, "het vierde item"
Interessante kenmerken van het Dictionary object.
- De Exits methode waarmee men kan uitzoeken indien een bepaald "key" (sleutelwaarde) met zijn bijhorende "item" waarde bestaat in het Dictionary object. Het komt erop neer dat het eenvoudiger is om te zoeken in het Dictionary object dan bij het Collection object of Arrays
- De CompareMode eigenschap zet men de wijze hoe teksten vergeleken worden:
- TextCompare
waarbij hoofd- of kleine letters geen belang hebben - BinaryCompare
hier is er wel een verschil tussen in tekst al naar gelang die in kleine of hoofdletters gesteld is.
- TextCompare
- Met de Key eigenschap kan men de 'sleutel waarde' voor een speciek Item in de Dictionary weergeven.
- Met de RemoveAll methode kan men allen Items uit een Dictionary object verwijderen.
Het voornaamste voordeel van het Dictionary object is dat het eenvoudiger is om het te doorzoeken en te vergelijken zoals blijkt uit volgende code voorbeeld/
Public Sub sVergelijkDic()
'Vergelijken van twee Dictionaries
Dim Dict1 As Dictionary
Dim Dict2 As Dictionary
Dim varHouder1 As Variant
Set Dict1 = New Dictionary
Set Dict2 = New Dictionary
With Dict1
.CompareMode = BinaryCompare
.Add 1, "het eerste item"
.Add 2, "het tweede item"
.Add 3, "het derde item"
.Add 4, "het vierde item"
End With
With Dict2
.CompareMode = BinaryCompare
.Add 1, "het eerste item_a"
.Add 2, "het tweede item"
.Add 4, "het vierde item_a"
End With
'Vergelijk de twee Dictionaries
For Each varHouder1 In Dict1
If Not Dict2.Exists(varHouder1) Then
Debug.Print "Sleutelwaarde " & varHouder1 & " is in Dict1 maar niet in Dict2"
Else ' Item exists so lets check the size.
If Dict2.Item(varHouder1) <> Dict1.Item(varHouder1) Then
Debug.Print "Het Item bij Sleutel " & varHouder1 & " is verschillend"
End If
End If
Next
End Sub
Bovenstaande geeft als resultaat :
Het Item bij Sleutel 1 is verschillend
Sleutelwaarde 3 is in Dict1 maar niet in Dict2
Het Item bij Sleutel 4 is verschillend
Het Filesystem object.
Met het FileSystemObject kan men via code vrij gemakkelijk met bestanden en mappen werken.
Men kan naar bestanden zoeken, lijsten maken van bestanden in een bepaalde map, nagaan indien
bepaalde bestanden bestaan, bestanden verwijderen, copieëren, tekstbestanden creëren en er naar schrijven.
Volgende tabel geeft een overzicht eigenschappen en methodes van het FileSystemobject.
| FileSystemObject | Hoofd object | Informatie ophalen over schijven, mappen, bestanden, creëren en verwijderen van bestanden |
| Drive | Drive | Informatie ophalen over schijven. |
| Drives | Collectie | Oplijsting van zowel fysische als logische schijven. |
| File | Object | Creëren, verwijderen en verplaatsen van bestanden, ophalen van bestandseigenschappen. |
| Files | Collectie | Oplijsting van alle bestanden in een map. |
| Folder | Object | Creëren, verplaatsen en verwijderen van mappen, ophalen van de eigenschappen van een map. |
| Folders | Collectie | Oplijsten van alle mappen in een map. |
| TextStream | Object | Lezen van en schrijven naar tekstbestanden |
Voorbeeld van Drive en Drives
Public Sub sSchijven()
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim schijf As Drive
For Each schijf In fso.Drives
Debug.Print schijf.DriveLetter & " " & schijf.DriveType
If schijf.IsReady Then
Debug.Print schijf.FreeSpace
End If
Next
End Sub
Weergeven van de submappen in een map
Public Function fTelSubMappen(ByVal strStartMap As String) As String
Dim fso As FileSystemObject
Dim TopMap As Folder
Dim HuidigeMap As Folder
Dim subMap As Folder
Dim strResultaat As String
Dim intAantMappen As Integer
Set fso = New FileSystemObject
Set TopMap = fso.GetFolder(strStartMap)
strResultaat = "De grote van de " & TopMap.Name & " = " & Format(TopMap.Size, "#,##0") & vbCrLf
strResultaat = strResultaat & TopMap.Name & " werd aangemaakt op " & TopMap.DateCreated & vbCrLf
intAantMappen = 0
For Each HuidigeMap In TopMap.SubFolders
strResultaat = strResultaat & " " & HuidigeMap & vbCrLf
intAantMappen = intAantMappen + 1
Next HuidigeMap
fTelSubMappen = strResultaat & vbCrLf & " aantal submappen : " & intAantMappen
Set TopMap = Nothing
Set fso = Nothing
End Function
Weergeven van de bestanden in een map en bestaat een bestand ?
Public Function fGeefBestanden(strMap As String) As String
Dim fso As FileSystemObject
Dim bestand As File
Dim map As Folder
Dim strResultaat As String
Dim intAantal As Integer
Set fso = New FileSystemObject
If fso.FolderExists(strMap) Then
Set map = fso.GetFolder(strMap)
strResultaat = "Bestanden in " & map.Name & vbCrLf
For Each bestand In map.Files
strResultaat = strResultaat & bestand.Name & " " & Format(bestand.Size, "#,##0") & ", groot" & vbCrLf
intAantal = intAantal + 1
Next
strResultaat = strResultaat & "In totaal " & intAantal & " bestanden."
End If
fGeefBestanden = strResultaat
End Function
Bestaat een bestand?
Public Function fBestaatBestand(strBestandNaam As String) As Boolean
'strBestandNaam moet het volledig pad + naam weergeven
Dim fso As FileSystemObject
Dim bestand As File
fBestaatBestand = False
Set fso = New FileSystemObject
If fso.FileExists(strBestandNaam) Then
Set bestand = fso.GetFile(strBestandNaam)
fBestaatBestand = True
End If
End Function
Bestaan submappen zo neen, maak ze aan.
Voor bepaalde van mijn toepassingen zijn submappen in de map van de database noodzakelijk. In plaats van de gebruikers daarmee te belasten controleert een functie in het opstart formulier indien de submappen bestaan, zoniet worden ze gemaakt.
Public Function fBestaanSubMappen(strSubMappen As String) As Boolean
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Project :DB-uittreksels
'Omschrijving: Nagaan indien de vereiste submappen bestaan in de map van de database,zoniet aanmaken
'Auteur:www.boterbloem.org
'Datum creatie: 01/02/2011
'Datum Herzien:
'Kommentaar:submappen opgeven in één string gescheiden door |
'
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim avarMappen() As String
Dim intAantSubMappen As Integer
Dim intDum As Integer
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If gInProducie Then On Error GoTo FoutBehandeling
fBestaanSubMappen = False
avarMappen() = Split(strSubMappen, "|")
intAantSubMappen = UBound(avarMappen)
For intDum = 0 To intAantSubMappen
If Not fso.FolderExists(CurrentProject.Path & "\" & avarMappen(intDum)) Then
fso.CreateFolder (CurrentProject.Path & "\" & avarMappen(intDum))
End If
Next intDum
fBestaanSubMappen = True
Verlaten:
On Error Resume Next
Exit Function
FoutBehandeling:
If Not fFoutVerwerking("fBestaanSubMappen", "basDB", "") Then
Stop
End If
Resume Verlaten
End Function
Veel gebruikte methode's van het FileSystemObject.
| Methode | Toelichting | Syntax |
| CreateFolder | Maakt een nieuwe map aan | fso.CreateFolder "C:\documenten\map" |
| CreateTextFile | Aanmaken van tekst-bestand en retourneert een Texstream object om te schrijven naar of lezen van het bestand | fso.CreateTextFile "c:\documenten\map\bestand.txt" |
| DeleteFolder | Een map verwijderen | fso.DeleteFolder "C:\documenten\map" |
| DeleteFile | Een bestand verwijderen | fso.DeleteFile "c:\documenten\map\bestand.txt" |
| CopyFile | Maakt een copie van een bestand | fso.CopyFile "C:\documenten\bestand.txt", "C:\documenten\bestand_copy.txt" |
| MoveFile | Verplaatsen van een bestand | fso.MoveFile "C:\documenten\bestand.txt", "C:\documenten\map\bestand.txt" |
Een tekstbestand maken en ernaar schrijven.
Public Function fMaakBestand(strNaamEnPad As String) As Boolean
Dim fso As FileSystemObject
Dim fsoStroom As TextStream
Set fso = New FileSystemObject
Set fsoStroom = fso.CreateTextFile(strNaamEnPad, True)
fsoStroom.WriteLine "hallo aangemaakt bestand"
fsoStroom.WriteBlankLines (2)
fsoStroom.WriteLine "einde van mijn bestand!"
fsoStroom.Close
If fso.FileExists(strNaamEnPad) Then
MsgBox strNaamEnPad & " aangemaakt "
fMaakBestand = True
End If
Set fsoStroom = Nothing
Set fso = Nothing
End Function
Tekst toevoegen aan tekstbestand.
Public Function fToevoegenAanBestand(strNaamEnPad) As Boolean
Dim fso As FileSystemObject
Dim fsoStroom As TextStream
Dim Bestand As File
Set fso = New FileSystemObject
Set Bestand = fso.GetFile(strNaamEnPad)
Set fsoStroom = Bestand.OpenAsTextStream(ForAppending) 'kan ook ForReading of ForWriting zijn
fsoStroom.WriteLine "Lijn die aan het tekstbestand toegevoegd wordt"
fsoStroom.Close
fToevoegenAanBestand = True
Set fsoStroom = Nothing
Set fso = Nothing
End Function
Lezen van tekstbestand
De 'OpenAsTextStream' methode van 'File' met parameter ForReading retourneert een TextStream en wordt gebruikt om van een tekstbestand te lezen.
Daartoe heeft het TextStream object 3 methodes :
- Read Heeft als parameter het aantal karakters die te lezen is.
- ReadAll Leest het volleddige bestand
- ReadLine Leest een lijn van het tekstbestand
Public Function fLezenVanBestand(strNaamEnPad) As String Dim fso As FileSystemObject Dim fsoStroom As TextStream Dim Bestand As File Dim strGelezen As String Set fso = New FileSystemObject If fso.FileExists(strNaamEnPad) Then Set Bestand = fso.GetFile(strNaamEnPad) Set fsoStroom = Bestand.OpenAsTextStream(ForReading) Do While Not fsoStroom.AtEndOfStream strGelezen = strGelezen & fsoStroom.ReadLine & vbCrLf Loop fsoStroom.Close Set fsoStroom = Nothing Set Bestand = Nothing fLezenVanBestand = strGelezen End If Set fso = Nothing End Function
HTML-bestand aanmaken in plaats van Access Rapport
Niettegenstaande men mooie en overzichtelijke Access rapporten kan maken, en deze in een PDF formaat bewaren, kan het genereren van een HTML
bestand in bepaalde gevallen een goed alternatief bieden.
De opmaak mogelijkheden bij een HTML document zijn legio. Bovendien kan een
HTML-document eenvoudig omgezet worden in een MS Word document. Hierbij moet men
wel in acht nemen dat de HTML-stijl declaraties binnen het HTML docment zelf
moet geschreven worden en niet in een afzonderlijk *.css bestand.
Feitelijk is een HTML document een gewoon tekstbestand die via gebruik te maken
van het FileSystemObject object kan aangemaakt worden.
Voorbeeld.
Een Access toepassing waarbij geheugenstijn lijstjes kunnen opgemaakt worden
wanneer men op reis vertrekt. Wat men moet meenemen en waar men ze bewaart.
Men kan kiezen tussen verschillende reistypes. En vervolgens per Categorie
de items weergeeft en waar hun plaats is.
Om te beginnen maakt men een globale Module waar men de constanten
declareert om de hoofd onderdelen van het HTML bestand aan te maken.
'++++++++++++++++++++++++++++++++++++++++
'om HTML bestand aan te maken
Public Const strAanhaal As String = "'"
Public Const strSpatie As String = " "
Public Const strDoc As String = "<!DOCTYPE html PUBLIC " & strAanhaal & "-//W3C//DTD XHTML 1.0 Transitional//EN " & strAanhaal & strSpatie
& strAanhaal & "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" & strAanhaal & ">"
Public Const strStartHTML As String = "<html xmlns=" & strAanhaal & "http://www.w3.org/1999/xhtml" & strAanhaal & ">"
Public Const strStartHead As String = "<head>"
Public Const strStijl As String = "<link href=" & strAanhaal & "basis.css" & strAanhaal & " rel=" & strAanhaal & "stylesheet" &
strAanhaal & " type=" & strAanhaal & "text/css" & strAanhaal & ">"
Public Const strTitel As String = "<title>Geheugensteun lijsten</title>"
Public Const strEindHead As String = "</head>"
Public Const strStartBody As String = "<body class=" & strAanhaal & "achtergrond" & strAanhaal ">"
Public Const strEindBody As String = "</body>"
Public Const strEindHTML As String = "</head>"
Public Const strStijlInt As String = ">style>" _
& ".achtergrond {background-color: #C0C0C0;}" _
& ".nadruk {font-family: Arial, Helvetica, sans-serif;font-weight: bold;font-size:14px}" _
& ".categorie {font-family: Arial, Helvetica, sans-serif;font-size: 16px;font-weight: bold;color: #000080;}" _
& ".waar {font-family: Arial, Helvetica, sans-serif;font-size: 13px;color: #006600;}" _
& ".rest { font-family: Arial;font-size: 12px;}" _
& "</style>"
Vervolgens de Functie, die twee argumenten heeft
1. De naam van het HTML bestand (die men zelf moet kiezen
2. Het reistype , van het datatype Long
Public Function fMaakHTML_S(strNaamHTML As String, lngIDReistype As Long) As Boolean
Dim db As DAO.Database
Dim rstReistype As DAO.Recordset
Dim rstCategorie As DAO.Recordset
Dim lngIDCategorie As Long
Dim rstWat As DAO.Recordset
Dim objFSO As FileSystemObject
Dim objTxtstream As TextStream
On Error GoTo FoutBehandeling
fMaakHTML_S = False
Set objFSO = New FileSystemObject
Indien het HTML bestaat, eerst verwijderen,
de functie av_f_MapDB geeft de Map van de Database, het HTML bestand wordt dus indezelfde map aangemaakt.
If objFSO.FileExists(av_f_MapDB & strNaamHTML) Then
objFSO.DeleteFile (av_f_MapDB & strNaamHTML)
End If
Set objTxtstream = objFSO.CreateTextFile(av_f_MapDB & "/" & strNaamHTML)
Set db = CurrentDb
Set rstReistype = db.OpenRecordset("SELECT Reistype FROM tblReistype WHERE IDReistype = " & lngIDReistype & " ORDER BY Reistype;")
If Not rstReistype.RecordCount = 0 Then
rstReistype.MoveFirst
Er is maar één Loop
Do Until rstReistype.EOF
objTxtstream.WriteLine (strDoc)
objTxtstream.WriteLine (strStartHTML)
objTxtstream.WriteLine (strStartHead)
objTxtstream.WriteLine (strStijlInt)
objTxtstream.WriteLine (strTitel)
objTxtstream.WriteLine (strEindHead)
objTxtstream.WriteLine (strStartBody)
objTxtstream.WriteLine ("<h2>" & rstReistype("Reistype") & "</h2>")
rstReistype.MoveNext
Loop
Set rstCategorie = db.OpenRecordset("SELECT Categorie,IDCategorie FROM qagAanmaakBestand WHERE IDReistype = " & lngIDReistype & " ORDER BY Categorie;")
If Not rstCategorie.RecordCount = 0 Then
objTxtstream.WriteLine ("<ol>")
rstCategorie.MoveFirst
gegevens per categorie schikken, is buitenste loop
Do Until rstCategorie.EOF
lngIDCategorie = rstCategorie("IDCategorie")
'Debug.Print lngIDCategorie
objTxtstream.WriteLine ("<li class=" & strAanhaal & "categorie" & strAanhaal & ">" &
rstCategorie("Categorie") & "</li>")
Set rstWat = db.OpenRecordset("SELECT Wat,Waar,Turfomschrijving FROM qselAanMaakBestand WHERE IDReistype = " & lngIDReistype &
" AND IDCategorie = " & lngIDCategorie & " ORDER By Wat;")
If Not rstWat.RecordCount = 0 Then
objTxtstream.WriteLine ("<ul class=" & strAanhaal & "rest" & strAanhaal & " >")
al de items van deze categorie, binnenste loop
Do Until rstWat.EOF
objTxtstream.WriteLine ("<li >" & "<span class=" & strAanhaal & "nadruk" & strAanhaal & ">" &
rstWat("Wat") & "</span> -" & "<span class=" & strAanhaal & "waar" & strAanhaal & ">" &
rstWat("Waar") & "</span>" & "-" & rstWat("Turfomschrijving") & "</li>")
rstWat.MoveNext
Loop
objTxtstream.WriteLine ("</ul>")
End If
rstCategorie.MoveNext
Loop
objTxtstream.WriteLine ("</ol>")
End If
objTxtstream.WriteLine (strEindBody)
objTxtstream.WriteLine (strEindHTML)
End If
fMaakHTML_S = True
Verlaten:
On Error Resume Next
Exit Function
FoutBehandeling:
If Not dhError("fMaakHTML_S", False) Then
Stop
End If
Resume Verlaten
End Function
Email versturen via Groupwise.
Een referentie naar de Groupwise Library is noodzakelijk.Ik heb deze code veel toegepast ten einde bulk emails te versturen.
'Versturen van Tekst-email via Groupwise
Function ZendTekst(strSubject As String, strLichaam As String, strBestem As String) As Boolean
On Error GoTo FoutBehandeling
With New GroupwareTypeLibrary.Application
With .Login
With .MailBox.Messages.Add(Class:="GW.MESSAGE.MAIL")
.Subject.PlainText = strSubject
.BodyText.PlainText = strLichaam
.Recipients.Add strBestem
.Recipients.Resolve
.Send
End With
End With
End With
Verlaten:
On Error Resume Next
Exit Function
FoutBehandeling:
MsgBox "Fout in ZendTekst " & Err.Description & " " & Err.Number,vbCritical +vbOKOnly,"Er heeft zich een fout voorgedaan"
Resume Verlaten
End Function
'Versturen van Tekst-email met bijlage via Groupwise
Function ZendTekstA(strSubject As String, strLichaam As String, strBestem As String, strAttach As String) As Boolean
On Error GoTo FoutBehandeling
ZendTekstA = False
With New GroupwareTypeLibrary.Application
With .Login
With .MailBox.Messages.Add(Class:="GW.MESSAGE.MAIL")
.Subject.PlainText = strSubject
.BodyText.PlainText = strLichaam
.Recipients.Add strBestem
.Recipients.Resolve
.Attachments.Add strAttach
.Send
End With
End With
End With
ZendTekstA = True
Verlaten:
On Error Resume Next
Exit Function
FoutBehandeling:
MsgBox "Fout in ZendTekstA " & Err.Description & " " & Err.Number,vbCritical +vbOKOnly,"Er heeft zich een fout voorgedaan"
Resume Verlaten
End Function
Hiereen voorbeeld over het gebruik van bovenstaande functies om emails in bulk te versturen.De gegevens van de bestemmelingen worden geput uit een query 'qselIKLMail' waarvan de gegevens ingelezen worden in een DAO.Recordset. Men kan bemerken dat de mail gepersonaliseerd is.
Function fIntMailsVersturen(strSubject As String, strMessage As String, Optional varattach As Variant) As Boolean
Dim strSubjectOK As String
Dim strMessageOK As String
Dim strBestemOK As String
Dim strSQL As String
Dim strAttach As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim blnVerstuurd As Boolean
On Error GoTo FoutBehandeling
fIntMailsVersturen = False
strSQL = "SELECT NUMMER,VOORNAAM,NAAM,Email,WW FROM qselIKLEmail"
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL)
If rst.RecordCount <> 0 Then
rst.MoveLast
rst.MoveFirst
Do
strSubjectOK = strSubject & " / " & rst![Nummer] & " / " & rst![WW]
strMessageOK = "Beste " & rst![VOORNAAM] & vbCrLf & vbCrLf & strMessage
strBestemOK = rst![Email]
If IsMissing(varattach) Then
blnVerstuurd = ZendTekst(strSubjectOK, strMessageOK, strBestemOK)
Else
strAttach = CStr(varattach)
blnVerstuurd = ZendTekstA(strSubjectOK, strMessageOK, strBestemOK, strAttach)
End If
strSubjectOK = ""
strMessageOK = ""
strBestemOK = ""
rst.MoveNext
Loop Until rst.EOF
Else
GoTo Verlaten
End If
fIntMailsVersturen = True
Verlaten:
On Error Resume Next
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
Exit Function
FoutBehandeling:
MsgBox "Fout in fIntMailsVersturen " & Err.Description & " " & Err.Number,vbCritical +vbOKOnly,"Er heeft zich een fout voorgedaan"
Resume Verlaten
End Function
- Getal tussen twee grenzen
- Conversie datum aanduiding
- Controle email adres
- Snelheid in km/uur
- Minuten per km
- Seconden per km
Willekeurig getal tussen een maximum en minimum weergeven.
Gebruikmakend van de VBA Rnd functie en het VBA Randomize Statement, kan zowel voor gehele getalen als voor getallen met het
opgegeven decimale na de komma.
Wanneer minimum en maximum geen gehele getallen zijn, moet in de functie een punt gebruikt worden als decimaal scheidingsteken.
Public Function GetalWillekeur(lngMin As Long, lngMax As Long, _
Optional Decimalen As Integer)
If IsMissing(Decimalen) Or Decimalen = 0 Then
Randomize
GetalWillekeur = Int((lngMax + 1 - lngMin) * Rnd + lngMin)
Else
Randomize
GetalWillekeur = Round((lngMax - lngMin) * Rnd + lngMin, Decimalen)
End If
End Function
Een datum aanduiding jjjjmmdd weergeven in vorm dd/mm/jjjj.
Veel van de toepassingen die ik ontworpen heb werkten met data die afgeladen werd van een Oracle database, de datum aanduiding was numeriek in de vorm van jjjjmmdd.
Function fDatConv(varDatum As Variant) As Date
On Error Resume Next
If Not IsNull(varDatum) Then
fDatConv = CDate(Right(varDatum, 2) & "/" & Mid(varDatum, 5, 2) & "/" & Left(varDatum, 4))
End If
End Function
Controleren indien een email-adres het juiste formaat heeft.
De functie maakt gebruik van de Microsoft VBScript Regular Expressions, via Tools moet er een referentie naar deze bibliotheek gelegd worden.
Function f_EmailCorrect(strEmail As String) As Boolean
'Om verkeerde email adressen eruit te filteren
Dim strOut As String
Dim re As VBScript_RegExp_10.regexp
Dim tokens As MatchCollection
f_EmailCorrect = False
Set re = New VBScript_RegExp_10.regexp
re.Pattern = "\b(\w+\.)*\w+@\w+(\.\w+)+\b"
re.IgnoreCase = True
If re.test(strEmail) Then
' er is een match
Set tokens = re.Execute(strEmail)
f_EmailCorrect = True
End If
Afstand en snelheid voor hardlopers
Ik heb ooit een Access toepassing gemaakt waar joggers hun prestaties en trainingschema's in kunnen bijhouden, onderstaande functies komen uit deze toepassing. De laatste twee functies moeten samen gebruikt worden ten einde het aantal minuten + seconden voor één afgelegde km te kennen op basis van de snelheid in Km per uur.
Snelheid in Km per uur op basis van afstand en tijd in uren, minuten, seconden.
Public Function fKmPUur(ByVal varAfstandKm As Variant, ByVal bytUur As Byte, ByVal bytMin As Byte, Optional bytSec As Byte = 0) As Single
Dim sngTijdUur As Single
Dim sngAfstand As Single
sngTijdUur = 1 / 3600 * (bytUur * 3600 + bytMin * 60 + bytSec)
If sngTijdUur = 0 Then
fKmPUur = 0
Else
If Not IsNull(varAfstandKm) Then
sngAfstand = CSng(varAfstandKm)
End If
fKmPUur = sngAfstand / sngTijdUur
End If
End Function
Bemerk dat het argument seconden niet verplicht is in te geven, indien geen seconden worden in gegeven, neemt de functie 0 seconden. Gebruik :
Dim sngSnelheid as Single
sngSnelheid = fKmPUur(42,192,3,21,15)
Afstand en snelheid voor hardlopers
Ik heb ooit een Access toepassing gemaakt waar joggers hun prestaties en trainingschema's in kunnen bijhouden, onderstaande functies komen uit deze toepassing.
Deze functie moeten samen gebruikt worden met de volgende functie ten einde het aantal minuten + seconden voor één afgelegde km te kennen op basis van de snelheid in Km per uur.
Aantal minuten per km op basis van de snelheid in Km per uur.
Public Function fMinPKm(ByVal varKmPUur As Variant) As Byte
If Not IsNull(varKmPUur) Then
fMinPKm = Int(60 / varKmPUur)
End If
End Function
Afstand en snelheid voor hardlopers
Ik heb ooit een Access toepassing gemaakt waar joggers hun prestaties en trainingschema's in kunnen bijhouden, onderstaande functies komen uit deze toepassing.
Deze functie moeten samen gebruikt worden met de vorige functie ten einde het aantal minuten + seconden voor één afgelegde km te kennen op basis van de snelheid in Km per uur.
Aantal seconden per km op basis van de snelheid in Km per uur.
Public Function fSecPKm(varKmPUur As Variant) As Byte
If Not IsNull(varKmPUur) Then
fSecPKm = Int((3600 / varKmPUur)) Mod 60
End If
End Function
Mod is een operator die gebruikt wordt om twee getallen door elkaar te delen en enkel de rest weer te geven vb 10 Mod 3 retourneert 1 gebruik
Dim sngSnelheid as Single
Dim strAfstandMinSec as String
sngSnelheid = fKmPUur(42,192,3,21,15)
strAfstandMinSec = fMinPKm(sngSnelheid) & " minuten " & fSecPKm(sngSnelheid) & " en seconden per km."
hallo