Re : Macro d'envoi d'emails fonctionnant mais pas dans perso.xls
Effectivement en tapant à la main le nom de la macro j'arrive à lancer une macro. Cependant, j'ai toujours la même erreur alors que je n'ai pas cette erreur quand le module est dans un classeur normal...
Voici mon code :
Sub send_mail()
' --------------------------
Dim i As Integer
Dim j As Integer
Dim oEmail As Outlook.MailItem
Dim appOutLook As Outlook.Application
Dim x As String
Dim y As String
Dim z As String
Dim name As String
Dim MaLigne As String
Dim Part1 As String
Dim Part2 As String
Dim Part3 As String
' créer un nouvel item mail
Set appOutLook = New Outlook.Application
Set oEmail = appOutLook.CreateItem(olMailItem)
' Cherche la plage du détail
x = ActiveCell.Row
name = ActiveSheet.name
MaLigne = Sheets(name & "_Source").Range("A65536").End(xlUp).Row - 3
For i = 1 To MaLigne
If Sheets(name & "_Source").Cells(i, 1).Value = Sheets(name).Cells(x, 1).Value And Sheets(name & "_Source").Cells(i, 2).Value = Sheets(name).Cells(x, 2).Value Then
y = i
i = MaLigne - 4
Else
End If
Next i
If Sheets(name & "_Source").Cells(y + 1, 1).Value = "" Then
z = y + 2
Else
z = Sheets(name & "_Source").Cells(y, 1).End(xlDown).Row + 2
End If
'Première partie du message texte
Part1 = "<FONT face=Arial size=2>" _
& "Dear " & Sheets(name).Cells(x, 10).Value & " and " & Sheets(name).Cells(x, 11).Value & "," _
& "<BR><BR><BR>" _
& "In Pack 01 of " & Right(Sheets(name).Cells(7, 1), 3) & ", we have the following intercos mismatches (In Euro)." _
& "<BR><BR>" _
& "Please kindly reconcile with your counterparts and send me an agreed answer." _
& "<BR><BR>" _
& "Thank you." _
& "<BR><BR><BR>" _
& "<b><u>" & Sheets(name).Cells(3, 1).Value & "</u></b>" _
& "<BR><BR>"
'Deuxième partie du message texte
Part2 = "<table><tr ALIGN=center><td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("A13").Value & "</FONT></td>" _
& "<td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("B13").Value & "</FONT></td>" _
& "<td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("C13").Value & "</FONT></td>" _
& "<td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("D13").Value & "</FONT></td>" _
& "<td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("E13").Value & "</FONT></td>" _
& "<td width=90 style='border-bottom:1 solid black'><FONT face=Arial size=2>" & Sheets(name & "_Source").Range("F13").Value & "</FONT></td></tr>"
For i = y To z - 1 'nombre de lignes (exemple plage A1:B5)
Part2 = Part2 & "<tr ALIGN=center>"
For j = 1 To 6 'nombre de colonnes
Part2 = Part2 & "<TD><FONT face=Arial size=2>" _
& Sheets(name & "_Source").Cells(i, j) & "</FONT></TD>"
Next j
Part2 = Part2 & "</TR>"
Next i
Part2 = Part2 & "<tr ALIGN=center>"
For j = 1 To 6 'nombre de colonnes
Part2 = Part2 & "<TD><FONT face=Arial size=2><b>" _
& Sheets(name & "_Source").Cells(z, j) & "<b></FONT></TD>"
Next j
Part2 = Part2 & "</TR></TABLE>"
'Troisième partie du message texte
Part3 = "<BR><BR>" _
& "Regards,"
oEmail.BodyFormat = olFormatHTML
oEmail.To = Sheets(name).Cells(x, 10).Value & ";" & Sheets(name).Cells(x, 11).Value
oEmail.Subject = "Intercos " & Sheets(name).Cells(x, 1).Value & " - " & Sheets(name).Cells(x, 2).Value & " " & ActiveSheet.name & " " & Right(Sheets(name).Cells(7, 1), 3)
oEmail.HTMLBody = Part1 & Part2 & Part3
'affichage du mail
With oEmail
.Display
End With
' détruit les références aux objets
Set oEmail = Nothing
Set appOutLook = Nothing
End Sub
