Mailen van bestand met excel

vrouw · 19 jan 2016

Ik wil vanuit excel een bestand mailen dat al klaar staat met een vaste naam op de schijf.

Nu vind ik wel veel VBA voor het mailen met body`s en dergelijke maar wat ik zoek is een code waarbij ik aan kan geven waar het bestand staat die gemaild moet worden met een vast adres dat in de code staat.

Bij Ron de bruin heb ik deze gevonden die ik moet gaan gebruiken denk ik maar kom er niet uit met de bijlage mee mailen.
Ik denk dat deze code ook te lang is omdat mijn bestand al klaar staat op de schijf.

Code:

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

OctaFish · 19 jan 2016

Als het alleen om de mail functionaliteit gaat, en om het kiezen van een bestand, dan kun je een FileDialog gebruiken om het bestand op te zoeken:

Code:

Sub Mail_ActiveSheet()
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

    ' Kies één bestand
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Show
        TempFileName = .SelectedItems(1)
    End With
    
''    ' Kies meerdere bestanden bestanden
''    Dim lngCount As Long
''    With Application.FileDialog(msoFileDialogFilePicker)
''        .Show
''        .AllowMultiSelect = True
''        ' Display paths of each file selected
''        For lngCount = 1 To .SelectedItems.Count
''            If TempFileName <> "" Then TempFileName = TempFileName & ","
''            TempFileName = TempFileName & .SelectedItems(lngCount)
''        Next lngCount
''    End With

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

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add Destwb.TempFileName
        .Send   'or use .Display
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

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

Ik heb er ook een stukje bijgezet voor het geval je meerdere bestanden tegelijk wilt kunnen kiezen. Die moet je dan, bij het toevoegen van de Attachments, nog wel even splitsen.

VenA · 19 jan 2016

Als het bestand al klaar staat met een vaste naam dan is dit voldoende

Code:

Sub VenA()
With CreateObject("Outlook.Application").createitem(0)
    .to = [COLOR="#FF0000"]"vrouw"[/COLOR]
    .Subject =[COLOR="#FF0000"] "zie bijlage"[/COLOR]
    .attachments.Add [COLOR="#FF0000"]"D:\mijn bestand.xlsx"[/COLOR]
    .display '.send
End With
End Sub

De rood gemarkeerde tekst even aanpassen naar eigen wensen.

vrouw · 20 jan 2016

OEPS ik heb een verkeerd voorbeeld macro in mijn eerste post gegeven.
Ik gebruik geen outlook dus deze gaat niet werken.

Ik mail nu ook wel vanuit excel maar dan met onderstaande macro.
Nadeel van de macro die ik nu wel gebruik (zie hieronder) is dat de ontvanger uit een .txt bestandje moet worden gehaald
maar ik wil het juist "hard" in de VBA zetten.

Hoe moet ik dan onderstaande code daarvoor aanpassen of een andere code gebruiken.
De bijlage die bij de mail moet worden meegezonden staat al klaar en opgeslagen op de schijf.

excuus voor de verwarring

Code:

Sub Send_met_de_Server()
   
   
 'haal de mailadressen uit bestand C:\Temp\mailadres.txt
   Open "C:\Temp\mailadres.txt" For Input As #1
  Do While Not EOF(1)
  Input #1, Read
  Mail = Mail & "," & Read
  Loop
  Debug.Print Mail
  Close #1
 
 
Set objMessage = CreateObject("CDO.Message")
    objMessage.FROM = """ TEST 2016 "" jan.jansen+test@firma.nl"
    objMessage.to = Mail
    objMessage.Subject = "==>> Update 2016. <<== "
    objMessage.TextBody = Replace("Beste Collega`s" & _
    "@@ " & _
    "@@ Hierbij een Update 2016." & _
    "@@ " & _
    "@@", "@", vbCrLf)
    
    
    objMessage.AddAttachment "C:\Temp\Voorraad.xls"
    
    objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.firma.nl"
    objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
                   
    objMessage.Configuration.Fields.Update

    On Error Resume Next
    objMessage.Send
    If Err.Number = 0 Then
    CreateObject("WScript.Shell").Popup "De mail is verzonden naar het adres in :\Temp\mailadres", 1, "Ik sluit vanzelf na 1 Seconde."
      Else
        MsgBox ("Mail " & DCKortPrev & " Het bestand is NIET verzonden.")
    End If
    
    
  
    End Sub

HSV · 20 jan 2016

Dan zou dit voldoende moeten zijn toch?

Code:

Sub Send_met_de_Server()
 with CreateObject("CDO.Message")
    .FROM = """ TEST 2016 "" jan.jansen+test@firma.nl"
    .to = [COLOR=#ff0000]"vrouw@provider.com"[/COLOR]
    .Subject = "==>> Update 2016. <<== "
    .TextBody = Replace("Beste Collega`s" & _
    "@@ " & _
    "@@ Hierbij een Update 2016." & _
    "@@ " & _
    "@@", "@", vbCrLf)
    
    
   .AddAttachment "C:\[COLOR=#ff0000]XXX[/COLOR]\Voorraad.xls"
    
   .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
   .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.firma.nl"
   .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
   .Configuration.Fields.Update

    On Error Resume Next
   .Send
    If Err.Number = 0 Then
    CreateObject("WScript.Shell").Popup "De mail is verzonden naar het adres in :\Temp\mailadres", 1, "Ik sluit vanzelf na 1 Seconde."
      Else
        MsgBox ("Mail " & DCKortPrev & " Het bestand is NIET verzonden.")
    End If
    end with
End Sub

vrouw · 20 jan 2016

SUPER, hartelijk dank :thumb:

Mailen van bestand met excel

vrouw

Terugkerende gebruiker

OctaFish

Verenigingslid

VenA

Inventaris

vrouw

Terugkerende gebruiker

HSV

Inventaris

vrouw

Terugkerende gebruiker

Nieuwste berichten

Wij waarderen jouw privacy