Envoyer worksheet par mail ? OK ! Reste pdf & Save ...

Envoyer worksheet par mail ? OK ! Reste pdf & Save ... - VB/VBA/VBS - Programmation

Marsh Posté le 11-04-2008 à 15:13:58    

Bonjour,  
J'ai dégotté une macro me permettant d'envoyer (en .xslm) une worksheet spécifique d'un workbook contenant une adresse email.(dans la cellulue M73)  
J'essaie en vain d'envoyer cette worksheet en .pdf et de sauver ce pdf sur mon ordi. (avec le meme nom de fichier, c'est nickel)  
J'utilise Foxit et CutePDf, mais si il faut utiliser un autre programme, suis tout ouvert.(Outlook et Excel 2007)  
Je ne suis pas des plus a l'aise avec les macros, mais si qqn peut aider et que ca ne lui prend pas trop de temps, ce serait top. D'avance, mille mercis. Diego  
Voici la macro qui envoie le worksheet par mail :  
 
Sub Mail_Every_Worksheet()  
'Working in 2000-2007  
Dim sh As Worksheet  
Dim wb As Workbook  
Dim FileExtStr As String  
Dim FileFormatNum As Long  
Dim TempFilePath As String  
Dim TempFileName As String  
Dim OutApp As Object  
Dim OutMail As Object  
 
TempFilePath = Environ$("temp" ) & "\"  
 
If Val(Application.Version) < 12 Then  
'You use Excel 97-2003  
FileExtStr = ".xls": FileFormatNum = -4143  
Else  
'You use Excel 2007  
FileExtStr = ".xlsm": FileFormatNum = 52  
End If  
 
With Application  
.ScreenUpdating = False  
.EnableEvents = False  
End With  
 
Set OutApp = CreateObject("Outlook.Application" )  
OutApp.Session.Logon  
 
For Each sh In ThisWorkbook.Worksheets  
If sh.Range("M73" ).Value Like "?*@?*.?*" Then  
 
sh.Copy  
Set wb = ActiveWorkbook  
 
TempFileName = Format(Now, "dd-mmm-yy h-mm-ss" )  
 
Set OutMail = OutApp.CreateItem(0)  
With wb  
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum  
On Error Resume Next  
With OutMail  
.To = Range("M73" )  
.CC = ""  
.BCC = ""  
.Subject = ""  
.Body = " "  
.Attachments.Add wb.FullName  
'You can add other files also like this  
'.Attachments.Add ("C:\test.txt" )  
.Send 'or use .Display  
End With  
On Error GoTo 0  
.Close SaveChanges:=False  
End With  
Set OutMail = Nothing  
 
'Kill TempFilePath & TempFileName & FileExtStr  
End If  
Next sh  
 
Set OutApp = Nothing  
 
With Application  
.ScreenUpdating = True  
.EnableEvents = True  
End With  
End Sub

Reply

Marsh Posté le 11-04-2008 à 15:13:58   

Reply

Marsh Posté le 14-04-2008 à 14:17:10    

Merci Kiki !
Have a great day.

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed