Bug ds Envoie onglet par mail

[CelluleVide]

Bonjour le forum,
J'ai mis bout a bout plusieurs codes empruntés ici pour envoyer le contenu d'un onglet dans le corps du message. Ca bug a l'instruction "Readfile" et je ne vois pas pourquoi.

Sub PrepareOutlookMail()
Dim sFileName As String
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")

' Si Outlook n'était pas ouvert, l'instruction ci-dessous aura eu pour conséquence de démarrer Outlook. Ce type de démarrage par automation fait apparaître une fenêtre de sécurité qui demande à l'utilisateur de permettre au programme de continuer.
'Le message est "A program is trying to send an email. Do you want to allow..." ' Dans le cas où l'utilisateur aurait cliqué sur No, l'objet appOutlook est égal à Nothing. Il est donc impossible de continuer.

If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
oMail.HTMLBody = ReadFile(sFileName) CA BUG ICI
oMail.Display
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub

 

[PMO2]

Re : Bug ds Envoie onglet par mail

Bonjour,

D'après ma connaissance, la fonction ReadFile n'est pas une instruction du VBA mais une API Windows ???

Voici une piste l'utilisant avec la démarche suivante

1) dans un nouveau classeur créez un UserForm (Name UserForm1) avec 2 OptionButton (Name OptionButton1 et OptionButton2) ainsi
que 2 CommandButton (Name CommandButton1 et CommandButton2)
Dans la fenêtre de code du UserForm copiez le code suivant

Private Sub CommandButton1_Click()
If OptionButton1 Then
  Call PublishHTML(xlSourceWorkbook, vbNullString)
ElseIf OptionButton2 Then
  Call PublishHTML(xlSourceSheet, ActiveSheet.Name)
End If
Call CreeMail
Unload Me
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
With Me
  .OptionButton1.Caption = "Faire paraître le classeur entier"
  .OptionButton1 = True
  .OptionButton2.Caption = "Faire paraître la feuille active"
  .CommandButton1.Caption = "OK"
  .CommandButton2.Caption = "Annuler"
End With
End Sub

2) dans un module standard, copiez le code suivant

'################################################################
'### Nécessite la Library Outlook (menu Outils/Références...) ###
'###        Microsoft Outlook xx.0 Object Library             ###
'###  C:\Program Files\Microsoft Office\OFFICE11\msoutl.olb   ###
'################################################################

Public Const MON_HTM As String = "___tempPmo.htm"

Private Declare Function CreateFile& Lib "kernel32" Alias "CreateFileA" ( _
  ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
  ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, _
  ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long)
Private Declare Function SetFilePointer& Lib "kernel32" ( _
  ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, _
  ByVal dwMoveMethod As Long)
Private Declare Function GetFileSize& Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long)
Private Declare Function ReadFile& Lib "kernel32" ( _
  ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _
  lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any)
Private Declare Function CloseHandle& Lib "kernel32" (ByVal hObject As Long)

Const FILE_BEGIN = 0
Const FILE_SHARE_READ = &H1
Const OPEN_EXISTING = 3
Const GENERIC_READ = &H80000000

Sub Excel2MailOutlook()
UserForm1.Show (vbModeless)
End Sub

Sub CreeMail(Optional dummy As Byte)
Dim sFileName As String
Dim appOutlook As New Outlook.Application
Dim oMail As Outlook.MailItem
Dim A$
On Error GoTo Erreur
Set oMail = appOutlook.CreateItem(olMailItem)
A$ = LireFichier(ActiveWorkbook.Path & "\" & MON_HTM)
If A$ = "" Then Error = 65535
Kill ActiveWorkbook.Path & "\" & MON_HTM
oMail.HTMLBody = A$
oMail.Display
Erreur:
If Not oMail Is Nothing Then Set oMail = Nothing
If Not appOutlook Is Nothing Then Set appOutlook = Nothing
End Sub

Public Function LireFichier(ByRef FileName As String) As String
Dim Hndl&
Dim Taille&
Dim i&
Dim Fichier$
On Error GoTo ErrorHandler
Hndl& = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ, 0&, OPEN_EXISTING, 0, 0)
SetFilePointer Hndl&, 0, 0, FILE_BEGIN  'par précaution, pointeur en tête du fichier
Taille& = GetFileSize(Hndl&, 0)
Fichier$ = Space(Taille&)
ReadFile Hndl&, ByVal Fichier$, Taille&, i&, ByVal 0&
CloseHandle Hndl&
LireFichier = Fichier$
Exit Function
ErrorHandler:
MsgBox "Le Fichier " & FileName & " n'a pu être lu."
End Function

Public Sub PublishHTML(TypeSource As Long, SheetName As String)
With ActiveWorkbook.PublishObjects.Add( _
  SourceType:=TypeSource&, _
  FileName:=ActiveWorkbook.Path & "\" & MON_HTM, _
  Sheet:=SheetName, HtmlType:=xlHtmlCalc)
  .Publish create:=True
End With
End Sub

Il est impératif de faire référence à la librairie Outlook.

Lancez la macro Excel2MailOutlook. Le classeur actif OU la feuille active selon l'OptionButton choisi est reproduit dans le
corps du mail avec l'interactivité.

Cordialement.

PMO
Patrick Morange