email met bijlage via macroknop

[Nico10]

Als leek al veel gevonden dankzij jullie op dit forum ivm VAB.

Mijn probleem is het volgende, we zouden bonnen moeten doorsturen in outlook (1blad zie bijlage) waarvan het emialadres van de ontvanger steeds wijzigd (dmv vertkaal zoeken), cel G31.Ook de bonnummer in Cel G3 wijzigd steeds dmv vertikaal zoeken en zou het onderwerp van de email moeten zijn.De mail met bijdrage zou moeten openen in outlook zodat we er nog een mededeling kunnen in schrijven.Wie kan ons op de goede weg zetten.
Alvast bedankt.

 

[spaarie]

Opzetje

Sub Spaarie()
    Sheets("Bon").Copy
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\Bon " & .ActiveSheet.Range("C1").Value & ".xls"
        b = ActiveWorkbook.FullName
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ActiveSheet.Range("G31").Value
            .Subject = ActiveSheet.Range("G3").Value
            .Body = ""
            .Attachments.Add b
            .Display
        End With
        .Close True
        Kill b
    End With
End Sub

 

[Nico10]

Hey, spaarie lukt aardig waarvoor dank.
Maar hoe en waar slaat hij deze op, ik zie in de c wel snelkoppelingen met die naam.
Wat is de logica hiervoor?
En kan je ons ook helpen om die bon eventueel op te slaan op een map vb op de desktop.

Alvast een dikke merci

 

[HSV]

Test het zo eens.
Er wordt een map genaamd 2014 aangemaakt op het bureaublad waarin het bestand is geplaatst.

Sub hsv()
Dim sFullName As String
Sheets("Bon").Copy
With ActiveWorkbook
 sFullName = Environ("USERPROFILE") & "\Desktop\" & Year(Date)
   If Dir$(sFullName, vbDirectory) = vbNullString Then MkDir sFullName
        .SaveAs sFullName & "\Bon " & .ActiveSheet.Range("C1").Value & ".xls"
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ActiveSheet.Range("G31").Value
            .Subject = ActiveSheet.Range("G3").Value
            .Body = ""
            .Attachments.Add sFullName & "\Bon " & ActiveSheet.Range("C1").Value & ".xls"
            .Display
        End With
        .Close True
    End With
End Sub

 

[Nico10]

Harry,
Sorry, maar bij het uitvoeren loopt het fout bij deze Then MkDir sFullName
Wat is de oplossing?

Alvast bedankt

 

[spaarie]

Maar hoe en waar slaat hij deze op, ik zie in de c wel snelkoppelingen met die naam.
Wat is de logica hiervoor?

Om overtollige tabbladen te verwijderen moest het tabblad gekopieerd worden naar een eigen bestand. Deze moet opgeslagen worden eer je deze kan toevoegden aan een email. Vandaar dat ik hem ook liet opslaan, maar liet hem ook verwijderen (Kill b).

Om een beetje voor te borduren op Harry zijn code. Nu maakt de code een mapje aan met het huidige jaartal op de locatie waar ook het bestand staat opgeslagen. In dat mapje komt het bestandje wat ook verstuurd wordt.

Sub Spaarie()
    If Sheets("Bon").Range("C1").Value = "" Then
        MsgBox "Geef kenteken in.", vbInformation + vbOKOnly, "Oeps..."
        Exit Sub
    End If
    
    Sheets("Bon").Copy
    With ActiveWorkbook
        p = ThisWorkbook.Path & "\" & Year(Date)
        If Dir(p) = "" Then MkDir p
        .SaveAs p & "\Bon " & .ActiveSheet.Range("C1").Value & ".xls"
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ActiveSheet.Range("G31").Value
            .Subject = ActiveSheet.Range("G3").Value
            .Body = ""
            .Attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        .Close True
    End With
End Sub

Tevens ook een stukje toegevoegd dat als er geen kenteken staat dat de code niet gaat uitvoeren.

 

[HSV]

Harry,
Sorry, maar bij het uitvoeren loopt het fout bij deze Then MkDir sFullName

Vreemd, werkt hier perfect.

 

[Nico10]

Als ik dit eruit haal lukt het wel, vreemd.
If Dir (p)="" then mkDir p
Het eigenaardige was de eerste keer liep alles prima de 2de keer liep,het mis bij aangegeven lijn.

Alvast een dikke merci voor jullie hulp.

 

[spaarie]

Aangepast. Nu moet het toch echt werken...

Sub Spaarie()
    If Sheets("Bon").Range("C1").Value = "" Then
        MsgBox "Geef kenteken in.", vbInformation + vbOKOnly, "Oeps..."
        Exit Sub
    End If
    
    Sheets("Bon").Copy
    With ActiveWorkbook
        p = ThisWorkbook.Path & "\" & Year(Date)
        If Len(Dir(p, vbDirectory)) = 0 Then MkDir p
        .SaveAs p & "\Bon " & .ActiveSheet.Range("C1").Value & ".xls"
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ActiveSheet.Range("G31").Value
            .Subject = ActiveSheet.Range("G3").Value
            .Body = ""
            .Attachments.Add ActiveWorkbook.FullName
            .Display
        End With
        .Close True
    End With
End Sub

 

[HSV]

Deze zou ook moeten werken zonder een eigen pad.

Sub hsvtwee()
Dim sFullName As String
Sheets("Bon").Copy
With ActiveWorkbook
 sFullName =  CreateObject("WScript.Shell").SpecialFolders("Desktop") &"\" & Year(Date)
   If Dir$(sFullName, vbDirectory) = vbNullString Then MkDir sFullName
        .SaveAs sFullName & "\Bon " & .ActiveSheet.Range("C1").Value & ".xls"
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ActiveSheet.Range("G31").Value
            .Subject = ActiveSheet.Range("G3").Value
            .Body = ""
            .Attachments.Add sFullName & "\Bon " & ActiveSheet.Range("C1").Value & ".xls"
            .Display
        End With
        .Close True
    End With
End Sub

 

[Nico10]

Mannen,


Lukt prima nu, waarvoor onze dank.
Super formum, wat zouden we zijn zonder jullie.

 

[Nico10]

Mag ik hieromtrent nog iets vragen,

Lukt prima maar is het ook mogelijk om deze op te slaan en door te mailen in word?

Alvast bedankt.