Access VBA tips & trucs (28-1-2010)

Vragen beantwoord ik tegen betaling van een uurtarief van € 60,- met een minimum van 1 uur

I N H O U D S O P G A V E

Access VBA tips & trucs (28-1-2010)

1 Functie om bedragen in klassen te verdelen

2 Rijen uit een rapport om en om kleuren

3 Voorbeeldcode opslaan veranderingen in aparte historietabel

4 Controle burger servicenummer

5 Gegevens van Access naar Word formuliervelden

6 Functie om Nederlandse weeknummer af te leiden .

7 Functie om de leeftijd te berekenen

• Functie om bedragen in klassen te verdelen

Function klasse(getal As Long) As String

Dim j As Long

j = 100000

klasse = Int((getal - 1) / j) * j + 1 & "-" & Int(getal / j) * j + j

End Function

• Rijen uit een rapport om en om kleuren

Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)

Dim ctl As Control

For Each ctl In Detail.Controls

ctl.BackStyle = 0

If Detail.BackColor = RGB(200, 255, 255) Then

Detail.BackColor = RGB(255, 200, 255)

Else

Detail.BackColor = RGB(200, 255, 255)

End If

End Sub

• Voorbeeldcode opslaan veranderingen in aparte historietabel

Sub logWijziging(frm As Form, recid As String)

Dim bron As String, naam As String, geb As String, ctlText As Control

naam = frm.Name

bron = frm.RecordSource

geb = CurrentUser

For Each ctlText In frm.Controls

'als de inhoud van een control van het type textbox veranderd is

'wordt de procedure historie aangeroepen

If ctlText.ControlType = acTextBox Then

'met acTextbox kijken we alleen naar controls van het type text

If ctlText.Value <> ctlText.OldValue Then

'bovenstaande test of er verschil is tussen de huidige inhoud en de vorige

Call historie(recid, bron, naam, geb, ctlText.Name, ctlText.OldValue, ctlText.Value)

'de waarden tussen haakjes worden meegegeven naar de procedure historie

End If

Next ctlText

End Sub

Sub logWijziging(frm As Form, recid As String)

Dim bron As String, naam As String, geb As String, ctlText As Control

naam = frm.Name

bron = frm.RecordSource

geb = CurrentUser

For Each ctlText In frm.Controls

'als de inhoud van een control van het type textbox veranderd is

'wordt de procedure historie aangeroepen

If ctlText.ControlType = acTextBox Then

'met acTextbox kijken we alleen naar controls van het type text

If ctlText.Value <> ctlText.OldValue Then

'bovenstaande test of er verschil is tussen de huidige inhoud en de vorige

Call historie(recid, bron, naam, geb, ctlText.Name, ctlText.OldValue, ctlText.Value)

'de waarden tussen haakjes worden meegegeven naar de procedure historie

End If

Next ctlText

End Sub

Sub historie(recid As String, bron As String, naam As String, geb As String, veld As String, oud As String, nieuw As String)

'de waarden tussen haakjes worden ontvangen als de procedure wordt aangeroepen

'deze procedure plaatst een aantal gegevens in een tabel historie als de gebruiker wijzigingen in een formulier

'aanbrengt dat deze procedure aanroept bij de before_update gebeurtenis van het formulier

'ook bij toevoegen

'voor het volgende moet de Microsoft DAO 3.6 library gekoppeld zijn (voor Access 97 versie 3.5)

Dim db As dao.Database

Dim rs As dao.Recordset

'Dim conn As DAO.Connection

'conn.Execute(sql)

'db.execute(sql)

'bovenstaande roept twee objecten in het leven: een database en een recordset

Set db = CurrentDb

'stelt db gelijk aan de huidig geopende database

'met set db = opendatabase("....") open je een andere database

Set rs = db.OpenRecordset("tblHistorie")

'het volgende stuk voegt een nieuw record toe, vult de waarden in en schrijft het weg naar de tabel

With rs

.AddNew

.Fields("datumwijziging").Value = Date

.Fields("tijdwijziging").Value = Time

.Fields("wijzigingdoor").Value = geb

.Fields("recordbron").Value = bron

.Fields("formnaam").Value = naam

.Fields("recordnummer").Value = recid

.Fields("veld").Value = veld

.Fields("oudeWaarde").Value = oud

.Fields("nieuweWaarde").Value = nieuw

.Update

End With

'hieronder worden de boven gedeclareerde en gevulde objecten gesloten en uit het geheugen gehaald

rs.Close

Set rs = Nothing

db.Close

Set db = Nothing

End Sub

• Controle burger servicenummer

Function Bsn(s)

Dim getal As Integer

getal = 9 * Mid(s, 1, 1)

getal = getal + 8 * Int(Mid(s, 2, 1))

getal = getal + 7 * Int(Mid(s, 3, 1))

getal = getal + 6 * Int(Mid(s, 4, 1))

getal = getal + 5 * Int(Mid(s, 5, 1))

getal = getal + 4 * Int(Mid(s, 6, 1))

getal = getal + 3 * Int(Mid(s, 7, 1))

getal = getal + 2 * Int(Mid(s, 8, 1))

getal = getal + -1 * Int(Mid(s, 9, 1))

'MsgBox getal

If getal Mod 11 = 0 Then

Bsn = True

Else

Bsn = False

End If

End Function

• Gegevens van Access naar Word formuliervelden

Private Sub cmdWord_Click()

Dim db As Database

Dim rs As Recordset

Set db = CurrentDb

Set rs = db.OpenRecordset("reserveren")

rs.AddNew

rs.Fields("reserveren").Value = Me.Achternaam.Value

rs.Update

Dim wrd As Word.Application

Set wrd = CreateObject("Word.Application")

wrd.Visible = True

wrd.Activate

wrd.WindowState = wdWindowStateMaximize

wrd.Documents.Add "c:\data\walmar\cursussen\oefeningen\eigen\access\brief.dot"

wrd.ActiveDocument.FormFields("achternaam").Result = Me.Achternaam.Value

wrd.ActiveDocument.FormFields("voorletter").Result = Me.Voorletter.Value

If Me.Voorvoegsel.Value <> "" Then

wrd.ActiveDocument.FormFields("voorvoegsel").Result = Me.Voorvoegsel.Value

End If

End Sub

• Functie om Nederlandse weeknummer af te leiden

Function weekNummerNL(datum As Date) As String

'integer als output: geheel getal

'date als input: datum

Dim intWeeknr As Integer

intWeeknr = DatePart("ww", datum, 2, 2)

weekNummerNL = "week " & Right("00" & intWeeknr, 2)

End Function

• Functie om de leeftijd te berekenen

Function leeftijd(datum)

If Month(Date) > Month(datum) Then

leeftijd = Year(Date) - Year(datum)

Else

If Month(Date) < Month(datum) Then

leeftijd = Year(Date) - Year(datum) - 1

Else

If Day(Date) < Day(datum) Then

leeftijd = Year(Date) - Year(datum) - 1

Else

leeftijd = Year(Date) - Year(datum)

End If

End Function