Private Function BedrijfMail()
Dim aWord As Object, oWord As Word.Document
Dim rst As ADODB.Recordset
Dim strVP As Variant
strPad = CurrentProject.Path & "\Dagelijks\" 'Pad voor uitleveringen
strMergePad = CurrentProject.Path & "\Merge\" 'Document voor emailmerge
strMergeDoc = strMergePad & "Merge.doc"
strSQL = "Select * From tUitleverMergeBedrijf"
Set rst = New Recordset
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
strVP = rst.GetRows
If rst.RecordCount > 0 Then
'Nu in een loopje elk record apart exporteren naar Excel, en samenvoegen met het Word document
strFileTxT = strMergePad & "qUitleverMerge.xls"
For i = LBound(strVP) To UBound(strVP)
'Checken of bestand al bestaat. Doen we door te kijken of de bestandsnaam in de uitlevermap is te vinden.
strUitgeleverd = Trim(strVP(9, i)) & " - Leads " & date & ".doc"
temp = Dir(strPad & strUitgeleverd)
'Als het bestand nog niet bestaat, uitleveren!
If strUitgeleverd <> temp Then
strSQL = "SELECT * FROM tUitlevermergeBedrijf WHERE [ID] =" & strVP(5, i)
CurrentDb.QueryDefs.Delete ("qUitlevermerge")
Set temp = CurrentDb.CreateQueryDef("qUitleverMerge", strSQL)
'Verwijder het oude bestand, omdat de procedure anders crasht.
On Error Resume Next
Kill strFileTxT
Err.Clear
On Error GoTo 0
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qUitleverMerge", strMergePad & "qUitleverMerge.xls"
GoSub TijdLoop
'Voor elk record wordt de Word applicatie apart opgestart en afgesloten; dit voorkomt overtollige Word-sessies
strInfo_A = strInfo_A & Trim(strVP(9, i)) & " - Leads " & date & ".doc" & vbLf
Set aWord = CreateObject("Word.Application")
Set oWord = aWord.Documents.Open(strMergeDoc)
On Error Resume Next
With oWord.MailMerge
.Destination = wdSendToNewDocument
.Execute
End With
GoSub TijdLoop
'Bestand opslaan
strUitgeleverd = strPad & Trim(strVPNaam(i)) & " - Leads " & date & ".doc"
oWord.Application.ActiveDocument.SaveAs (strPad & strUitgeleverd)
oWord.Application.ActiveDocument.Close
oWord.Close (wdDoNotSaveChanges)
Set oWord = Nothing
aWord.Application.Quit
End If
Next
End If
'Recordset en applicaties netjes afsluiten
rst.Close
Set rst = Nothing
Set db = Nothing
Set aWord = Nothing
'Echo na afloop altijd op True zetten, omdat je anders een leeg scherm overhoudt
DoCmd.Echo True
'En voor de zekerheid nog een keertje alles afsluiten...
On Error Resume Next
aWord.Quit
Set aWord = Nothing
Exit Function
'==========================================================================
'Hieronder staan de subroutines die boven in de code worden aangesproken.
'--------------------------------------------------------------------------
TijdLoop:
'Om te voorkomen dat de programmatuur zich verslikt, een kleine pauze van 1 seconde...
Start = 0
Start = Timer ' Aanvangstijd instellen.
Do While Timer < Start + 1
DoEvents ' Overdragen aan andere processen.
Loop
Return
'--------------------------------------------------------------------------
Stoppen:
On Error Resume Next
Set rst = Nothing
Set oWord = Nothing
Set aWord = Nothing
DoCmd.Echo True
End Function
)
