Vanuit excel mailen doet hij 5 x achter elkaar

[HWV]

Beste,

Mailen via excel doe ik met onderstaande code, enkel als ik deze verstuur dan gaat hij hem 5 keer versturen.
Hoe kan ik er voor zorgen dat hij maar één keer gaat verzenden ?

Groet HWV

Sub Mail_Every_Worksheet()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
Sheets("Print").Select

'Working in 97-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 Klant
Set Klant = Worksheets("Print").Range("E10")

Dim Plaatsnaam
Set Plaatsnaam = Worksheets("Print").Range("E18")

Dim DebNr
Set DebNr = Worksheets("Print").Range("E8")

    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

    For Each sh In ThisWorkbook.Worksheets
        If email.Email_adres.Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = "" & Klant & " " & Plaatsnaam & " " _
                         & DebNr & " " _
                         & Format(Now, "dd-mmm-yy h mm")

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, _
                        FileFormat:=FileFormatNum
                On Error Resume Next
                .SendMail email.Email_adres.Value, _
                          "" & Klant & " " & Plaatsnaam & " " _
                         & DebNr & " " _
                         & Format(Now, "dd-mmm-yy h mm")
                On Error GoTo 0
                .Close savechanges:=False
            End With

        End If
    Next sh

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

 

[snb]

Door de code goed te lezen en geen code te gebruiken die je niet begrijpt.
De code van Rond de Bruijn is een beetje als de macrorecorder van Excel: handig voor het basisidee, maar te reducren tot 10% met behoud van funktionaliteit.
Hoe zou het komen dat er vijf keer een email wordt verstuurd ? en wordt steeds hetzelfde verstuurd ?

 

[HWV]

Op weg

Beste,

Bedankt voor uw reactie.
U heeft inderdaad gelijk het zijn meerde bestanden, met de uitleg van u ben ik verder gaan zoeken en ben er dus achter gkomen dat jij elke sheet gaat verzenden.
Eigenlijk wil ik enkel maar de sheet Print hebben om te verzenden.
ik heb al wat geprobeerd maar zoals u al zeg ik snap de code nog niet helemaal maar probeer het wel te snappen.

[COLOR="Red"]For Each sh In ThisWorkbook.Worksheets[/COLOR]
        If email.Email_adres.Value Like "?*@?*.?*" Then

sh.Copy
            [COLOR="Red"]Set wb = ActiveWorkbook[/COLOR]

Het zal hier in zitten maar kom er nog niet achter wat de veranderingen zouden moeten zijn

groet HWV

 

[snb]

Zoek eens in dit forum naar suggesties die ik heb gedaan over emailen vanuit Excel.
Geef in eigen woorden weer wat elke regel in de VBA-code doet.
Dan kom je er vanzelf achter.

Bijvoorbeeld:

Sub verzend()
    With ThisWorkbook
        .HasRoutingSlip = True
        With .RoutingSlip
            .Recipients = [A1:A2]
            .ReturnWhenDone = False
            .TrackStatus = False
            .Subject = "Toezending adressenlijst"
            .Message = "Hierbij ontvangt u de meest recente adressenlijst."
            .Delivery = xlAllAtOnce
        End With
        .Route
    End With
End Sub

 

[HWV]

Gelukt

Beste,

Ik had uw aanpassing nog niet gezien, ik heb het werkend gekregen met onderstaande code (Ron de Bruin).
Ik ga zeker uw code proberen en ontleden hoe het werkt.

Bedankt voor het medenken

Groet HWV

Sub Mail_Every_Worksheet()
'Working in 2000-2010
    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 sheet to a new workbook
   Sheets("Print").Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 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 = frmTest.Txt_Voorletters.Value & " " & frmTest.Txt_Naam.Value & " " & frmTest.Txt_Plaats.Value & " " & "Nieuwe debiteur"

    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 = email.Email_adres.Value
            .CC = ""
            .BCC = ""
            .Subject = "Aanmaak nieuwe " & frmTest.Txt_kolom_QQ.Value & " " & frmTest.Txt_Voorletters.Value & " " & frmTest.Txt_Naam.Value & " " & frmTest.Txt_Plaats.Value
            .Body = "In de bijlage vind je een nieuwe" & " " & frmTest.Txt_kolom_QQ.Value & " om in gevoerd te worden in het systeem Dimasys" & vbCrLf & "Graag deze invoeren, en het nieuwe debiteurennummer aan mij doormailen" & vbCrLf & vbCrLf & "Met vriendelijke groet" & vbCrLf & vbCrLf & frmTest.Txt_kolom_AJ.Value
            .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