Beste forumleden,
Graag hulp bij de volgende VBA code die een specifiek rapport (brief) opent, print en opslaat als PDF op een netwerklocatie.
De bijgevoegde code werkt op zich wel, maar is abnormaal traag: printen en opslaan van één brief + bijlage kan soms wel 10 minuten duren! (en dit is geen netwerkprobleem)
Het lijkt me dat deze code aangepast kan worden ten gunste van de snelheid, maar hoe... graag hulp hierbij!
Met vriendelijke groet,
Bospeen
Graag hulp bij de volgende VBA code die een specifiek rapport (brief) opent, print en opslaat als PDF op een netwerklocatie.
De bijgevoegde code werkt op zich wel, maar is abnormaal traag: printen en opslaan van één brief + bijlage kan soms wel 10 minuten duren! (en dit is geen netwerkprobleem)
Het lijkt me dat deze code aangepast kan worden ten gunste van de snelheid, maar hoe... graag hulp hierbij!
Met vriendelijke groet,
Bospeen
Code:
Private Sub Knop1_Click()
On Error GoTo Err_Click
Const OverwriteExisting = True
Dim objFSO
Set objFSO = CreateObject("Scripting.Filesystemobject")
'--------------------------------------maakt een lege map op C voor tijdelijke opslag van brieven, dit werkt sneller dan direct opslaan op het tragere netwerk
If objFSO.FolderExists("c:\Temp\brieven") Then
objFSO.DeleteFolder "c:\Temp\brieven", True
objFSO.CreateFolder "c:\Temp\brieven"
Else
objFSO.CreateFolder ("c:\Temp\brieven")
End If
'--------------------------------------voorwaarden voor het mogen printen en opslaan van de brieven
If Me.BRIEF = False Then
MsgBox "De aktie kan niet worden voltooid (brief is niet aangevinkt)."
Exit Sub
End If
If IsNull(Me.DATUM_BRIEF) Then
MsgBox "De aktie kan niet worden voltooid (datum brief is niet gevuld)."
Exit Sub
End If
Else:
GoTo Printbrief:
End If
Printbrief:
If MsgBox("Kies in het printer-dialoogvenster hierna de juiste papierlade. Wacht daarna tot de melding dat printen en opslaan is voltooid.", vbOKCancel, "Brief printen en opslaan") = vbCancel Then
Exit Sub
End If
'--------------------------------------voorwaarde, printen, opslaan en melding brief_1
If Me.BEDRAG > 10000 Then
stlinkcriteria = "[zoekveld] = '" & Me![zoekveld] & "'"
DoCmd.OpenReport "brief_1", acViewReport, , stlinkcriteria
DoCmd.RunCommand acCmdPrint
DoCmd.OutputTo acOutputReport, "BRIEF_1", acFormatPDF, "C:\TEMP\brieven\" & Me.NAAM & "_brief_1.PDF", False
DoCmd.Close acReport, "brief_1", acSaveNo
MsgBox "Brief_1 is geprint en opgeslagen."
End If
'--------------------------------------voorwaarde, printen, opslaan en melding brief_2 en bijlage
If Me.BEDRAG > 5000 Then
stlinkcriteria = "[zoekveld] = '" & Me![zoekveld] & "'"
DoCmd.OpenReport "brief_2", acViewReport, , stlinkcriteria
DoCmd.RunCommand acCmdPrint
DoCmd.OutputTo acOutputReport, "brief_2", acFormatPDF, "C:\TEMP\brieven\" & Me.NAAM & "_brief_2.PDF", False
DoCmd.Close acReport, "brief_2", acSaveNo
DoCmd.OpenReport "brief_2_bijlage", acViewReport, , stlinkcriteria
DoCmd.RunCommand acCmdPrint
DoCmd.OutputTo acOutputReport, "brief_2_bijlage", acFormatPDF, "C:\TEMP\brieven\" & Me.NAAM & "_brief_2_bijlage.PDF", False
DoCmd.Close acReport, "brief_2_bijlage", acSaveNo
MsgBox "Brief_2 en bijlage is geprint en opgeslagen."
End If
'--------------------------------------definitief opslaan van de aangemaakte brieven in de archiefmap op het netwerk
objFSO.CopyFolder "c:\temp\brieven", "Q:\SERVERNAAM\ARCHIEF\BRIEVEN\" & Me.NAAM, OverwriteExisting
objFSO.DeleteFolder "c:\Temp\brieven", True
objFSO.CreateFolder "c:\Temp\brieven"
Me.Refresh
Exit Sub
Err_Click:
MsgBox "DE PRINT EN SAVE AKTIE IS AFGEBROKEN!"
End Sub