Je cherche à savoir comment (en VBA), utiliser la fonction d'excel qui est
"envoyer vers destinataire" et qui envoie automatiquement un fichier bitmap
de la feuille en cours à un destinataire.
Si je fais un enregistrement de macro, je n'obtient pas le code qui
m'interresserais pour mon appli.
Donc voilà, si quelqu'un connait la solution, je suis preneur,
Merci d'avance,
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Olivier B
Bonjour,
je n'ai pas vraiment le temps de te rédiger le code adapté à ton bitmap mais ce code que j'ai développé envoi automatiquement via outlook une sélection d'une feuille de calcul.
Le code vba transforme le contenu en html (les functions), puis envoi le tout par mail. Je pense donc qu'il doit y avoir moyen de bien réduire la partie code en ce qui te concerne.
Bon courage
----------- et bonne lecture.
Option Explicit
Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2007 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook
'Copy the range and create a new workbook to past the data in rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With
'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With
'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.readall ts.Close RangetoHTML = Replace(RangetoHTML, "alignÎnter x:publishsource=", _ "align=left x:publishsource=")
'Close TempWB TempWB.Close savechanges:úlse
'Delete the htm file we used in this function Kill TempFile
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
Function GetBoiler(ByVal sFile As String) As String 'Dick Kusleika Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.readall ts.Close End Function
Sub Mail_Range_Outlook_Body() ' Don't forget to copy the function RangetoHTML in the module. ' Working in Office 2000-2007 Dim rng As Range Dim OutApp As Object Dim OutMail As Object ActiveSheet.Unprotect With Application .EnableEvents = False .ScreenUpdating = False End With
Set rng = Nothing On Error Resume Next Set rng = Sheets("DA_Externe").Range("B1:F17").SpecialCells(xlCellTypeVisible) On Error GoTo 0
If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If
Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon Set OutMail = OutApp.CreateItem(0)
On Error Resume Next With OutMail 'j'ai mis l'email dans un cellule .To = Range("f18").Value .CC = "" .BCC = "" .Subject = "|||||| Création de DA Externe ||||||" .HTMLBody = RangetoHTML(rng) .Display 'ou .Send End With On Error GoTo 0
With Application .EnableEvents = True .ScreenUpdating = True End With
Set OutMail = Nothing Set OutApp = Nothing ActiveSheet.Protect DrawingObjects:úlse, Contents:=True, Scenarios:úlse End Sub
-- olivier
Bonjour,
Je cherche savoir comment (en VBA), utiliser la fonction d'excel qui est "envoyer vers destinataire" et qui envoie automatiquement un fichier bitmap de la feuille en cours un destinataire. Si je fais un enregistrement de macro, je n'obtient pas le code qui m'interresserais pour mon appli. Donc voil, si quelqu'un connait la solution, je suis preneur, Merci d'avance,
Marc
Bonjour,
je n'ai pas vraiment le temps de te rédiger le code adapté à ton bitmap mais
ce code que j'ai développé envoi automatiquement via outlook une sélection
d'une feuille de calcul.
Le code vba transforme le contenu en html (les functions), puis envoi le
tout par mail.
Je pense donc qu'il doit y avoir moyen de bien réduire la partie code en ce
qui te concerne.
Bon courage
----------- et bonne lecture.
Option Explicit
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "alignÎnter x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:úlse
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Mail_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
ActiveSheet.Unprotect
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng =
Sheets("DA_Externe").Range("B1:F17").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'j'ai mis l'email dans un cellule
.To = Range("f18").Value
.CC = ""
.BCC = ""
.Subject = "|||||| Création de DA Externe ||||||"
.HTMLBody = RangetoHTML(rng)
.Display 'ou .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
ActiveSheet.Protect DrawingObjects:úlse, Contents:=True,
Scenarios:úlse
End Sub
--
olivier
Bonjour,
Je cherche savoir comment (en VBA), utiliser la fonction d'excel qui est
"envoyer vers destinataire" et qui envoie automatiquement un fichier bitmap
de la feuille en cours un destinataire.
Si je fais un enregistrement de macro, je n'obtient pas le code qui
m'interresserais pour mon appli.
Donc voil, si quelqu'un connait la solution, je suis preneur,
Merci d'avance,
je n'ai pas vraiment le temps de te rédiger le code adapté à ton bitmap mais ce code que j'ai développé envoi automatiquement via outlook une sélection d'une feuille de calcul.
Le code vba transforme le contenu en html (les functions), puis envoi le tout par mail. Je pense donc qu'il doit y avoir moyen de bien réduire la partie code en ce qui te concerne.
Bon courage
----------- et bonne lecture.
Option Explicit
Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2007 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook
'Copy the range and create a new workbook to past the data in rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With
'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With
'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.readall ts.Close RangetoHTML = Replace(RangetoHTML, "alignÎnter x:publishsource=", _ "align=left x:publishsource=")
'Close TempWB TempWB.Close savechanges:úlse
'Delete the htm file we used in this function Kill TempFile
Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function
Function GetBoiler(ByVal sFile As String) As String 'Dick Kusleika Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.readall ts.Close End Function
Sub Mail_Range_Outlook_Body() ' Don't forget to copy the function RangetoHTML in the module. ' Working in Office 2000-2007 Dim rng As Range Dim OutApp As Object Dim OutMail As Object ActiveSheet.Unprotect With Application .EnableEvents = False .ScreenUpdating = False End With
Set rng = Nothing On Error Resume Next Set rng = Sheets("DA_Externe").Range("B1:F17").SpecialCells(xlCellTypeVisible) On Error GoTo 0
If rng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If
Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon Set OutMail = OutApp.CreateItem(0)
On Error Resume Next With OutMail 'j'ai mis l'email dans un cellule .To = Range("f18").Value .CC = "" .BCC = "" .Subject = "|||||| Création de DA Externe ||||||" .HTMLBody = RangetoHTML(rng) .Display 'ou .Send End With On Error GoTo 0
With Application .EnableEvents = True .ScreenUpdating = True End With
Set OutMail = Nothing Set OutApp = Nothing ActiveSheet.Protect DrawingObjects:úlse, Contents:=True, Scenarios:úlse End Sub
-- olivier
Bonjour,
Je cherche savoir comment (en VBA), utiliser la fonction d'excel qui est "envoyer vers destinataire" et qui envoie automatiquement un fichier bitmap de la feuille en cours un destinataire. Si je fais un enregistrement de macro, je n'obtient pas le code qui m'interresserais pour mon appli. Donc voil, si quelqu'un connait la solution, je suis preneur, Merci d'avance,