Bug ds Envoie onglet par mail

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

'################################################################
'### 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