Voor elke leerkracht wordt er een Excel aangemaakt en verstuurd. Het aantal kolommen in de Excel is variabel. Dit werkt voor het eerste record, maar voor het tweede record krijg ik de foutmelding 1004: Methode Range van object _Global is mislukt. Als laatste wat ik nu gedaan heb is de Range "rng" op .clear gezet omdat ik dacht dat het adres van de Range behouden bleef. De "Lbound" en "UBound" staan telkens goed. De array "arr(i)" wordt ook goed opgehaald. Zie het probleem niet. Zie gemarkeerde in code.
Code:
Do While Not .EOF ' en hier Excels maken en Macro uitvoeren en E-mail versturen
txtStamboeknummerVersturen = !GStamboeknummer
txtEmailAdres = ![GE-mailadres]
sqlVersturen = "SELECT tblBasisGebruikers.GNaam AS Naam, tblBasisGebruikers.GVoornaam AS Voornaam, tblBasisGebruikers.[GE-mailadres] AS [E-mailadres], tblBasisGebruikers.[GSO-nummer] AS [SO-nummer], " & _
"tblBasisGebruikers.GStamboeknummer AS Stamboeknummer, tblBasisGebruikers.GInstellingsnummer AS Instellingsnummer, tblLeerlingen.[Organisatie gebruikersnaam instelling] AS Instelling, " & _
"tblBasisGebruikers.GLeerjaar AS Leerjaar, tblBasisGebruikers.GKlas AS KLas, tblLeerlingen.[Leerling naam] AS [Naam leerling], tblLeerlingen.[Leerling voornaam] AS [Voornaam leerling], " & _
sqlString & " " & _
"FROM tblBasisGebruikers INNER JOIN tblLeerlingen ON (tblBasisGebruikers.GKlas = tblLeerlingen.[Klas code]) AND " & _
"(tblBasisGebruikers.GLeerjaar = tblLeerlingen.[Opleiding leerjaar]) AND (tblBasisGebruikers.GInstellingsnummer = tblLeerlingen.[Organisatie instellingsnummer]) " & _
"WHERE tblBasisGebruikers.GStamboeknummer = """ & txtStamboeknummerVersturen & """ " & _
"ORDER BY tblLeerlingen.[Leerling naam];"
'Maar hier ook een QueryDef van als virtuele recordset
Set qryVersturen = CurrentDb.CreateQueryDef("qryTemp", sqlVersturen)
'Hier het aantal records tellen om het aantal rijen in Excel te kennen
iAantalLeerlingen = DCount("*", "qryTemp") + 1
'Hier Excel aanmaken
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryTemp", "C:\IGEANToets_FE\TeVersturenExcels\" & txtStamboeknummerVersturen, True
'Dan Macro uitvoeren en LET OP het aantal domeinen
Dim iRijen As Long
Dim XL As Excel.Application
Dim OpenWerkboek As Excel.Workbook
Dim rng As Excel.Range
Dim txtRanges As String
Dim txtNaamKolom As String
Dim arr() As Variant
Set XL = CreateObject("Excel.Application")
Set OpenWerkboek = XL.Workbooks.Open("C:\IGEANToets_FE\TeVersturenExcels\" & txtStamboeknummerVersturen & ".xlsx")
txtRanges = ""
txtNaamKolom = "MOQSUWY" 'Let op slechts 7 domeinen maximaal toe te kennen
i = 1
With XL
.Visible = False 'waarom False?
.DisplayAlerts = False
With OpenWerkboek
'vanaf hier Excel formatting
'opletten op iAantalDomeinen!
'Bepaal het aantal Ranges volgens het aantal iAantalDomeinen
'Opnieuw de integer "i" gebruiken
For i = 1 To iAantalDomeinen
ReDim Preserve arr(i)
arr(i) = Mid(txtNaamKolom, i, 1)
Next i
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then
[COLOR="#FF0000"][B][U]Set rng = Range("" & arr(i) & "2:" & arr(i) & iAantalLeerlingen & "")[/U][/B][/COLOR] [COLOR="#FFFF00"][COLOR="#FF0000"]>> bij een tweede record loopt het hierop vast[/COLOR][/COLOR]
Else
Set rng = Union(rng, Range("" & arr(i) & "2:" & arr(i) & iAantalLeerlingen & ""))
End If
Next i
With rng.Validation
.Delete
.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=iMinPunten, Formula2:=iMaxPunten
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Punten ingeven"
.ErrorTitle = "Foute ingave"
.InputMessage = "Geef hier je punten in."
.ErrorMessage = "Geef juiste waarde in!"
.ShowInput = True
.ShowError = True
End With
End With
OpenWerkboek.Save
End With
rng.Clear
OpenWerkboek.Close
' XL.Close
Set rng = Nothing
Set OpenWerkboek = Nothing
Set XL = Nothing
'Dan versturen
Dim oOutlookApp As Object
Dim oEmail As Object
Set oOutlookApp = CreateObject("Outlook.Application")
Set oEmail = oOutlookApp.CreateItem(0)
With oEmail
.To = txtEmailAdres
.Subject = txtEmailOnderwerp
.Body = txtEmailBody
.Attachments.Add "C:\IGEANToets_FE\TeVersturenExcels\" & txtStamboeknummerVersturen & ".xlsx"
.display
' .Send
End With
'Hier EmailVerstuurd vervangen door cijfer 1
.Edit
!GEmailVerstuurd = 1
.Update
'Dan tijdelijke query verwijderen en op naar volgende leerkracht
DoCmd.DeleteObject acQuery, "qryTemp"
'de Excels die verstuurd is naar andere map verplaatsen: "C:\IGEANToets_FE\VerstuurdeExcels"
Dim ofs As Object
Set ofs = CreateObject("Scripting.FileSystemObject")
ofs.MoveFile "C:\IGEANToets_FE\TeVersturenExcels\" & txtStamboeknummerVersturen & ".xlsx", _
"C:\IGEANToets_FE\VerstuurdeExcels\" & txtStamboeknummerVersturen & ".xlsx"
Set ofs = Nothing
.MoveNext
Loop