Macro voor automatisch versturen tabblad Excel via Oulook

[Rivanlo]

Hallo,

Ik ben opzoek naar een macro waarmee ik één tabblad van een excel bestand automatisch kan doormailen naar één bepaald mailadres. Er moet een standaard onderwerp en tekst worden toegevoegd.

Groet,
Rivanlo

 

[Timshel]

Kijk hier eens naar:

Sub tsh()
    Dim TempFile As String
    
    TempFile = Environ("TEMP") & "\Test.xlsx"
    Sheets(1).Copy
    ActiveWorkbook.SaveAs TempFile, 51
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "Collega@Bedrijf.com"
        .Subject = "I make you an offer you can't refuse"
        .Body = "Hallo."
        .Attachments.Add TempFile
        .Display
    End With
    ActiveWorkbook.Close 0
    Kill TempFile
End Sub

 

[Rivanlo]

Ik heb het proberen te verzenden naar mijn eigen mail, maar hij komt niet aan. Is het ook mogelijk dat Outlook geopend wordt waarin dezelfde gegevens staan? En is dit enkel voor 1 tabblad of voor het hele document?

 

[peter59]

Hallo,

Of laat hier je licht eens op schijnen
http://www.rondebruin.nl/win/s1/outlook/amail2.htm

Mvg
Peter

 

[Timshel]

Ik heb het proberen te verzenden naar mijn eigen mail, maar hij komt niet aan.

Ik denk niet dat het aan de macro ligt.

Is het ook mogelijk dat Outlook geopend wordt waarin dezelfde gegevens staan?

Ik begrijp niet wat je bedoelt

En is dit enkel voor 1 tabblad of voor het hele document?

Ik heb de code enigszins herschreven zodat het actieve werkblad als tijdelijk bestand wordt opgeslagen en wordt aangehecht:

Sub tsh()
    Dim TempFile As String
    
    TempFile = Environ("TEMP") & "\Test.xlsx"
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs TempFile, 51
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "Collega@Bedrijf.com"
        .Subject = "I make you an offer you can't refuse"
        .Body = "Best Regards, the Don."
        .Attachments.Add TempFile
        .Display
    End With
    ActiveWorkbook.Close 0
    Kill TempFile
End Sub

 

[Rivanlo]

@Timshel

Volgens mij zit er in de laatste versie een fout. Alles gaat goed, maar ik ontvang de mail niet nadat het verzonden is.

 

[Rivanlo]

Ik wil eigenlijk de onderstaande twee macro`s samenvoegen. Van de eerste macro wil ik het openen van de nieuwe mail hebben waarbij ik nog aan kan passen wat nodig is. Van de tweede macro heb ik de kopie van de worksheet nodig die automatisch in de mail verschijnt.

Sub tsh()
Dim TempFile As String

TempFile = Environ("TEMP") & "\Test.xlsx"
Sheets(1).Copy
ActiveWorkbook.SaveAs TempFile, 51
With CreateObject("Outlook.Application").CreateItem(0)
.To = "Collega@Bedrijf.com"
.Subject = "I make you an offer you can't refuse"
.Body = "Hallo."
.Attachments.Add TempFile
.Display
End With
ActiveWorkbook.Close 0
Kill TempFile
End Sub

---------------------------------------------------------------------------------

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.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

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[peter59]

Hallo,

Als je in de 2de macro van Ron de Bruin .Send 'or use .Display de .Send 'or use weghaald dan wordt de mail getoond en kan in zijn geheel nog worden aangepast.
Dus mijn inziens hoeven deze 2 macro's niet samengevoegd te worden.
De 2de macro volstaat.

Mvg
Peter

 

[Rivanlo]

Ik heb het geprobeerd, maar het wil niet werken. Misschien dat ik nog iets anders moet verwijderen of wijzigen in de macro.

 

[peter59]

Welke foutmelding krijg je?
Of wat wil niet werken?

Mvg
Peter

 

[Rivanlo]

Hij reageert precies hetzelfde. Er gebeurt niks nieuws.

 

[peter59]

Hallo,

Probeer het voorbeeld eens.
Werkt hier (thuis) als een tierelier.

Mvg
Peter

 

[Rivanlo]

Dit voorbeeld werkt prima tot dat het verzonden wordt. De mail komt niet aan bij het opgegeven mailadres. Ik heb al verschillende mailadressen geprobeerd maar het lukt niet. De vorige macro met het automatische verzenden werkt wel. Is dit bij jou ook het geval?

 

[Rivanlo]

Nu werkt het wel! Het duurt gewoon een stuk langer dan de vorige macro`s. Bedankt!

 

[Timshel]

De vertraging heeft niets met de macro's te maken maar zit in Outlook. Mogelijk blijven de mails hangen in de outbox.