samenvoegen vba code voor telefoonlijst

[Frits.van Leeuwen]

Hallo allemaal,

Onregelmatig wordt mij gevraagd een telefoonlijst te maken. Deze maak ik dan
vanuit Access 2003. De telefoonlijst is opgebouwd uit verschillende
subformulieren. Vandaar dat ik een redelijk ingewikkeld stuk code in de Call
heb zitten.(deze staat verderop in deze mail)
Ik maak de telefoonlijst aan de voorzijde gesorteerd op voornaam en op de
achterzijde op achternaam. Tot nu toe gebruik ik daar het volgende voor (2
afzonderlijke knoppen):

Private Sub Afdrukken5_Click()
S1 = "voornaam"
Afdrukken5.SetFocus
Call Telefoonlijst(S1, Me.aantal_afdrukken)
End Sub

Private Sub Afdrukken6_Click()
S1 = "achternaam"
Afdrukken6.SetFocus
Call Telefoonlijst(S1, Me.aantal_afdrukken)
End Sub

Maar omdat ik dat het papier moet omdraaien dacht ik er aan om ze samen te
voegen. Ik maakte dit:

Private Sub Afdrukken5_Click()
S1 = "voornaam"
Afdrukken5.SetFocus
Call Telefoonlijst(S1, Me.aantal_afdrukken)
S1 = "achternaam"
Call Telefoonlijst(S1, Me.aantal_afdrukken)
End Sub

Maar helaas, dit werkt niet. Wie kan mij helpen?
Alvast bedankt.

De 2 stukjes afzonderlijk werken goed.
De Call die ik gebruik is de volgende:

Public Sub Telefoonlijst(S1 As String, Aantal As Integer)
'Bestaande tabel leegmaken, zodat deze opnieuw gevuld kan worden
DoCmd.SetWarnings False
DoCmd.OpenQuery "verwijderquery", acViewNormal, acEdit
DoCmd.SetWarnings True
DoCmd.Minimize

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Set rs.ActiveConnection = CurrentProject.Connection

'Open tijdelijk bestand voor de telefoon lijst
rs.Open "tbl_tijdelijk_tbv_telefoonlijst", , adOpenDynamic,
adLockOptimistic

'Alle werknemers
Dim rst, Rsp, Rsb As New ADODB.Recordset
Dim TelString, KmrString, tmpTel1, tmpKmr1, tmpTel2, tmpKmr2, Nam, KN As
String

Set rst = New ADODB.Recordset
Set rst.ActiveConnection = CurrentProject.Connection
rst.Open "Query_telefoonlijst_op_" & S1
rst.MoveFirst

Do Until rst.EOF 'zolang niet einde van de file
KN = "Persoon"
Nam = rst("naam").Value

TelString = rst("nr").Value 'alle telefoonnummers
tmpTel1 = rst("nr").Value '1e telefoonnummer
tmpTel2 = "" '2e telefoonnummer

KmrString = rst("kamer").Value 'alle kamernummers
tmpKmr1 = rst("kamer").Value '1e kamernummer
tmpKmr2 = "" '2e kamernummer

rst.MoveNext 'geeft foutmelding nr 3021 als laatste record is
bereikt
If Not rst.EOF Then

Do Until rst("naam").Value <> Nam 'zolang de naam gelijk is

'telefoonnummers op een rij zetten (Maximaal 3)
If rst("nr") <> tmpTel1 And rst("nr") <> tmpTel2 Then
TelString = TelString & ", " & rst("nr").Value
End If

'kamernummers op een rij zetten (Maximaal 3)
If rst("kamer") <> tmpKmr1 And rst("kamer") <> tmpKmr2 Then
KmrString = KmrString & ", " & rst("kamer").Value
End If

If Not rst.EOF Then
rst.MoveNext 'geeft foutmelding nr 3021 als laatste
record is bereikt
End If
Loop

End If

'Toevoegen van de records in tbl_tijdelijk_tbv_telefoonlijst
rs.AddNew
rs("kamer").Value = KmrString
rs("naam").Value = Nam
rs("nr").Value = TelString
rs("Persoon_Kamer") = KN
rs.Update
Loop

'Benoemde kamers
Set Rsp = New ADODB.Recordset
Set Rsp.ActiveConnection = CurrentProject.Connection
Rsp.Open ("Query_op_kameromschrijving")
Rsp.MoveFirst
Do Until Rsp.EOF
KN = "kamer"
Nam = Rsp("omschrijving").Value
TelString = Rsp("nr").Value
KmrString = Rsp("kamer").Value
Rsp.MoveNext

If Not Rsp.EOF Then
If Rsp("omschrijving").Value = Nam Then
If Rsp("nr") <> TelString And Not Rsp("kamer") = "---" Then
TelString = TelString & ", " & Rsp("nr").Value
Else
TelString = Rsp("nr").Value
End If
If Rsp("kamer") <> KmrString Then
KmrString = Rsp("kamer").Value
End If
If Not Rsp.EOF Or Rsp("kamer") = "---" Then
Rsp.MoveNext 'geeft foutmelding nr 3021 als laatste
record is bereikt
End If
End If
End If

'Toevoegen van de records in tbl_tijdelijk_tbv_telefoonlijst
rs.AddNew
rs("kamer").Value = KmrString
rs("naam").Value = Nam
rs("nr").Value = TelString
rs("Persoon_Kamer") = KN
rs.Update
Loop

'medewerkers BHV
Set Rsb = New ADODB.Recordset
Set Rsb.ActiveConnection = CurrentProject.Connection
Rsb.Open "Query_bhv_op_" & S1
Rsb.MoveFirst
Do Until Rsb.EOF
KN = "BHV"
Nam = Rsb("naam").Value
TelString = Rsb("nr").Value
KmrString = Rsb("kamer").Value
Rsb.MoveNext 'geeft foutmelding nr 3021 als laatste record is
bereikt
If Not Rsb.EOF Then
If Rsb("naam").Value = Nam Then
If Rsb("nr") <> TelString Then
TelString = TelString & ", " & Rsb("nr").Value
End If
If Rsb("kamer") <> KmrString Then
KmrString = KmrString & ", " & Rsb("kamer").Value
End If
If Not Rsb.EOF Then
Rsb.MoveNext 'geeft foutmelding nr 3021 als laatste
record is bereikt
End If
End If
End If

'Toevoegen van de records in tbl_tijdelijk_tbv_telefoonlijst
rs.AddNew
rs("kamer").Value = KmrString
rs("naam").Value = Nam
rs("nr").Value = TelString
rs("Persoon_Kamer") = KN
rs.Update
Loop
'medewerkers BHV
Set Rsb = New ADODB.Recordset
Set Rsb.ActiveConnection = CurrentProject.Connection
Rsb.Open "Query_EHBp_" & S1
Rsb.MoveFirst
Do Until Rsb.EOF
KN = "EHBO"
Nam = Rsb("naam").Value
TelString = Rsb("nr").Value
KmrString = Rsb("kamer").Value
Rsb.MoveNext 'geeft foutmelding nr 3021 als laatste record is
bereikt
If Not Rsb.EOF Then
If Rsb("naam").Value = Nam Then
If Rsb("nr") <> TelString Then
TelString = TelString & ", " & Rsb("nr").Value
End If
If Rsb("kamer") <> KmrString Then
KmrString = KmrString & ", " & Rsb("kamer").Value
End If
If Not Rsb.EOF Then
Rsb.MoveNext 'geeft foutmelding nr 3021 als laatste
record is bereikt
End If
End If
End If

'Toevoegen van de records in tbl_tijdelijk_tbv_telefoonlijst
rs.AddNew
rs("kamer").Value = KmrString
rs("naam").Value = Nam
rs("nr").Value = TelString
rs("Persoon_Kamer") = KN
rs.Update
Loop

rs.Close
Set rs = Nothing
rst.Close
Set rst = Nothing
Rsp.Close
Set Rsp = Nothing
Rsb.Close
Set Rsb = Nothing
Dim Teller As Integer
For Teller = 1 To Aantal
DoCmd.OpenReport "Rap_telefoonlijst", acViewNormal
Next Teller
' acViewDesign
' acViewNormal (standaard)
' acViewPreview
' acViewNormal heeft tot gevolg dat het rapport onmiddellijk wordt
afgedrukt. Als u niets opgeeft bij dit argument, wordt de
standaardinstelling (acViewNormal) gebruikt.
End Sub

 

[Tom van Stiphout]

On Mon, 20 Oct 2008 15:53:15 +0200, "Frits.van Leeuwen"

Men spreekt hier Engels.

It appears you missed the line
Afdrukken6.SetFocus
before calling the routine for the second time.

Looking at the code a bit more, this idea only works if
Me.aantal_afdrukken = 1. But I guess you can then put the printout in
a double-sided copier.

-Tom.
Microsoft Access MVP

 

[Frits.van Leeuwen]

Sorry to forgot speaking English.
Of cource I forgot the line Afdrukken6.SetFocus . This is not nessesary
anymore.
Your right about the double-sided copier. But I Like to do it with this
repport.
Otherwishe the script is longer then.