P
papou
Hi all
I am working on a routine in Word VBA to send each section issued from a
mail merge document to a new message using the Outlook 11.0 Object Library
(Outlook 2003).
Unfortunately, I cannot figure out how to paste my section into the new
Outlook message since the Paste method does not seem to exist in the outlook
Library.
I have tried using Sendkeys "^v" (which I usually avoid using because of
focus reasons) but this does not work either because of the security
warnings in Outlook even though I am bypassing them using the ClikYes
Programme.
I have also tried the AppOutlk.ActiveExplorer.Selection.PasteAndFormat
(wdFormatOriginalFormatting) method but to no avail.
In addtion, I cannot use (or find) any other method to send my message
because I need to add several attachments and use data from an excel
workbook (email addresses).
Has anybody encountered this before and found a working solution to this
issue?
TIA
Best regards
Pascal
Here's the code I run once my mail merge has been achieved:
Sub Testit()
Dim DocSource As Document
Dim i As Long
Dim NbUsers As Long
'#############################################
'Il s'agit du document Word issu de la fusion
Set DocSource = ActiveDocument
'#############################################
Dim AppOutlk As Outlook.Application
Dim OutlookAeteDemarre As Boolean
Dim MessageOutlk As Outlook.MailItem
On Error Resume Next
Set AppOutlk = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set AppOutlk = CreateObject("Outlook.Application")
OutlookAeteDemarre = True
End If
Dim AppXl As Excel.Application
Dim Classeur As Excel.Workbook
'La colonne du nom User :
Const NoCol As Long = 17
Set AppXl = GetObject(, "Excel.Application")
Set Classeur = AppXl.ActiveWorkbook
'Suppression de la 1ère ligne du classeur Excel (en-têtes)
Classeur.ActiveSheet.Rows(1).EntireRow.Delete
'Nombre de users (à partir de la colonne 17 (Q) du fichier Excel)
NbUsers = Classeur.Worksheets("Feuil1").Cells(65536, 17).End(xlUp).Row
'Pour chque ligne users
For i = 1 To NbUsers
Set MessageOutlk = AppOutlk.CreateItem(olMailItem)
With MessageOutlk
..Attachments.Add "C:\DOC\Robi11\Procédure de changement de mot de passe
utilisateur2.pdf"
..Attachments.Add "C:\DOC\Robi11\Procédure de récupération des règles outlook
2000.pdf"
..Recipients.Add (Classeur.ActiveSheet.Cells(i, 17).Value)
..BCC = "gern2"
'.BCC = "Penv1"
..Subject = "Programme COMET : votre planning"
..ReadReceiptRequested = True
..ReplyRecipients = "_1234"
..Importance = olImportanceHigh
..HTMLBody = "<HTML><BODY bgcolor=#90b6df></BODY></HTML>"
End With
DocSource.Sections(i).Range.Copy
MessageOutlk.Display
'AppOutlk.ActiveExplorer.Selection.PasteAndFormat
(wdFormatOriginalFormatting)
SendKeys ("^v")
'en cas de message d'avertissement de sécurité ActiveX
If Err <> 0 Then SendKeys ("~")
MessageOutlk.Send '(remplacer par Save pour les tests !)
Next i
'Killer process outlook si demarré
If OutlookAeteDemarre Then AppOutlk.Quit
'libérer les variables
Set AppOutlk = Nothing
Set MessageOutlk = Nothing
Classeur.Close (False)
Set AppXl = Nothing
Set Classeur = Nothing
End Sub
I am working on a routine in Word VBA to send each section issued from a
mail merge document to a new message using the Outlook 11.0 Object Library
(Outlook 2003).
Unfortunately, I cannot figure out how to paste my section into the new
Outlook message since the Paste method does not seem to exist in the outlook
Library.
I have tried using Sendkeys "^v" (which I usually avoid using because of
focus reasons) but this does not work either because of the security
warnings in Outlook even though I am bypassing them using the ClikYes
Programme.
I have also tried the AppOutlk.ActiveExplorer.Selection.PasteAndFormat
(wdFormatOriginalFormatting) method but to no avail.
In addtion, I cannot use (or find) any other method to send my message
because I need to add several attachments and use data from an excel
workbook (email addresses).
Has anybody encountered this before and found a working solution to this
issue?
TIA
Best regards
Pascal
Here's the code I run once my mail merge has been achieved:
Sub Testit()
Dim DocSource As Document
Dim i As Long
Dim NbUsers As Long
'#############################################
'Il s'agit du document Word issu de la fusion
Set DocSource = ActiveDocument
'#############################################
Dim AppOutlk As Outlook.Application
Dim OutlookAeteDemarre As Boolean
Dim MessageOutlk As Outlook.MailItem
On Error Resume Next
Set AppOutlk = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set AppOutlk = CreateObject("Outlook.Application")
OutlookAeteDemarre = True
End If
Dim AppXl As Excel.Application
Dim Classeur As Excel.Workbook
'La colonne du nom User :
Const NoCol As Long = 17
Set AppXl = GetObject(, "Excel.Application")
Set Classeur = AppXl.ActiveWorkbook
'Suppression de la 1ère ligne du classeur Excel (en-têtes)
Classeur.ActiveSheet.Rows(1).EntireRow.Delete
'Nombre de users (à partir de la colonne 17 (Q) du fichier Excel)
NbUsers = Classeur.Worksheets("Feuil1").Cells(65536, 17).End(xlUp).Row
'Pour chque ligne users
For i = 1 To NbUsers
Set MessageOutlk = AppOutlk.CreateItem(olMailItem)
With MessageOutlk
..Attachments.Add "C:\DOC\Robi11\Procédure de changement de mot de passe
utilisateur2.pdf"
..Attachments.Add "C:\DOC\Robi11\Procédure de récupération des règles outlook
2000.pdf"
..Recipients.Add (Classeur.ActiveSheet.Cells(i, 17).Value)
..BCC = "gern2"
'.BCC = "Penv1"
..Subject = "Programme COMET : votre planning"
..ReadReceiptRequested = True
..ReplyRecipients = "_1234"
..Importance = olImportanceHigh
..HTMLBody = "<HTML><BODY bgcolor=#90b6df></BODY></HTML>"
End With
DocSource.Sections(i).Range.Copy
MessageOutlk.Display
'AppOutlk.ActiveExplorer.Selection.PasteAndFormat
(wdFormatOriginalFormatting)
SendKeys ("^v")
'en cas de message d'avertissement de sécurité ActiveX
If Err <> 0 Then SendKeys ("~")
MessageOutlk.Send '(remplacer par Save pour les tests !)
Next i
'Killer process outlook si demarré
If OutlookAeteDemarre Then AppOutlk.Quit
'libérer les variables
Set AppOutlk = Nothing
Set MessageOutlk = Nothing
Classeur.Close (False)
Set AppXl = Nothing
Set Classeur = Nothing
End Sub