Beste experts,
ik gebruik Office 2016; mbv een loop worden Word documenten als e-mail verstuurd.
Tenzij Outlook actief is en tenminste één e-mailtje is geopend, bevat de eerste mail geen body. In alle andere e-mails daarna wordt de inhoud van het document met de correcte layout én evt afbeeldingen in de body van het bericht getoond. Hiervoor maak ik gebruik van de Outlook.Inspector.
Rubrieken zoals .SendingUserAccount, .To etc worden in alle e-mails correct gevuld.
Kunt u me verder helpen? Het liefst natuurlijk met een goed werkend voorbeeld...
Alvast bedankt voor de te nemen moeite,
Piet
Hieronder de code van de aanroepende subroutine 'SendTheMails()' en daaronder de subroutine ' SendDocAsMail' voor het maken/verzenden van de e-mail
ik gebruik Office 2016; mbv een loop worden Word documenten als e-mail verstuurd.
Tenzij Outlook actief is en tenminste één e-mailtje is geopend, bevat de eerste mail geen body. In alle andere e-mails daarna wordt de inhoud van het document met de correcte layout én evt afbeeldingen in de body van het bericht getoond. Hiervoor maak ik gebruik van de Outlook.Inspector.
Rubrieken zoals .SendingUserAccount, .To etc worden in alle e-mails correct gevuld.
Kunt u me verder helpen? Het liefst natuurlijk met een goed werkend voorbeeld...
Alvast bedankt voor de te nemen moeite,
Piet
Hieronder de code van de aanroepende subroutine 'SendTheMails()' en daaronder de subroutine ' SendDocAsMail' voor het maken/verzenden van de e-mail
Code:
Sub SendTheMails()
Dim iSendingAccount As Integer
Dim iSendType As Integer
Dim Ii, i, t, tmp, cTxt
Dim strArray() As String
Dim intCount As Integer
Dim sPath As String, sFile As String, sEmail As String
Dim msgIntro As String
cTxt = "0 - e-mail tonen en handmatig verzenden" & vbCrLf & _
"1 - e-mail niet tonen, direct verzenden"
Ii = InputBox(Title:="E-mail eerst tonen voor batch verzenden", _
Prompt:="Kies het nummer voor de actie:" & vbCrLf & cTxt, _
Default:=0)
If (Ii = "") Or (Not (Ii >= 0)) Then Exit Sub
iSendType = Ii
cTxt = ListallAccounts
i = InputBox(Title:="E-mail account voor batch verzenden", _
Prompt:="Kies het nummer van de afzender:" & vbCrLf & cTxt, _
Default:=0)
If (i = "") Or (Not (i > 0)) Then Exit Sub
iSendingAccount = i
' Allow the user to write a short intro and put it at the top of the body
msgIntro = InputBox("Write a short intro to put above your default " & _
"signature and current document." & vbCrLf & vbCrLf & _
"Press Cancel to create the mail without intro and " & _
"signature.", "Intro", "Deze e-mail is automatisch samengesteld.")
Application.ScreenUpdating = False
For t = LBound(aEmailAddress) To UBound(aEmailAddress)
If Not (Trim(aEmailAddress(t)) = "") Then
'prep for sending
strArray = Split(aEmailAddress(t), cDelimiter)
sPath = strArray(0)
sFile = strArray(1) & ".docx"
sEmail = strArray(2)
Documents.Open FileName:=sPath & sFile, ReadOnly:=True
Documents(sFile).Activate
'sending the email...
SendDocAsMail iSendType, iSendingAccount, sEmail, msgIntro, sSubject
End If
Next t
'closing single documents sent...
For t = LBound(aEmailAddress) To UBound(aEmailAddress)
If Not (Trim(aEmailAddress(t)) = "") Then
strArray = Split(aEmailAddress(t), cDelimiter)
sPath = strArray(0)
sFile = strArray(1) & ".docx"
sEmail = strArray(2)
Documents(sFile).Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
Next t
Documents(sBrieven).Activate
Application.ScreenUpdating = True
End Sub
Sub SendDocAsMail(ByVal iSendType As Integer, ByVal iSendingAccount As Integer, _
sEmail As String, msgIntro As String, cSubject As String)
'late binding...
Const IsNothing = ""
Dim oOutlookApp As Object
Dim oItem As Outlook.MailItem
Dim i As Integer
On Error Resume Next
'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
'Copy the open document
Selection.WholeStory
Selection.Copy
Selection.End = True
'Set the WordEditor
Dim objInsp As Outlook.Inspector
Dim wdEditor As Word.Document
Set objInsp = oItem.GetInspector
Set wdEditor = objInsp.WordEditor
'Write the intro if specified
If (msgIntro = IsNothing) Then
i = 1
'Comment the next line to leave your default signature below the document
wdEditor.Content.Delete
Else
'Write the intro above the signature
wdEditor.Characters(1).InsertBefore (msgIntro)
i = wdEditor.Characters.Count
wdEditor.Characters(i).InlineShapes.AddHorizontalLineStandard
wdEditor.Characters(i + 1).InsertParagraph
i = i + 2
End If
'Place the current document under the intro and signature
wdEditor.Characters(i).PasteAndFormat (wdFormatOriginalFormatting)
'Display the message
With oItem
.SendUsingAccount = oOutlookApp.Session.Accounts.Item(iSendingAccount)
.To = sEmail 'Cell.Value
.CC = ""
.BCC = ""
.Subject = cSubject
' .Body = taken care of by: wdEditor.Characters(i).PasteAndFormat (wdFormatOriginalFormatting)
If (iSendType <> 1) Then
.Display
Else
.Send
End If
End With
oItem.WindowState = olMinimized
objInsp.WindowState = olMinimized
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing
End Sub