Mailijst maken VBA Excel

Status
Niet open voor verdere reacties.
C

covux

Gebruiker
Lid geworden
9 sep 2016
Berichten
99
Hey,

Ben nog steeds bezig met een formulier.
Loop nu tegen een probleem aan om het bestand te email naar verschillende mensen.
Het punt is dat niet elk formulier naar dezelfde mensen moet gaan.
Dit is allemaal afhankelijk van wat mensen invullen in het formulier.

Nu dacht ik dus op een tweede blad in Excel een lijst te maken met de mensen die de email kunnen krijgen. Dan achter elke cel een constructie te maken als bepaalde opties WAAR zijn dat dan deze persoon ook de email krijgt.
Op het internet zijn genoeg voorbeelden te vinden die kunnen doen wat ik wil.
Alleen kom ik er niet uit om mijn versie werkende te krijgen.

Misschien kunnen jullie mij vertellen wat ik verkeerd doe.

In blad1( blad2) staat de code die ik graag wil gebruiken.

In ( Sheet1) overdrachtsormulier 2.0 staat ook een code voor een email.
Maar die heeft geen variable email lijst.


Code: 
Private Sub CommandButton1_Click()

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("F").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "G").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "K").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .Display  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub


Bekijk bijlage Helpmij versie.xlsm
 
Misschien moet ik een nieuw topic maken maar dan hoor ik dat wel.

Hoe kan ik meerdere Subs onder 1 knop plaatsen.

Ik heb dus nu de verzend sub om een email te sturen.

maar voor de dat email wordt gemaakt moet er nog een controle plaats vinden om te kijken of alle tekstvakjes zijn ingevuld.

Daarvoor heb ik de volgende code

Code: 
Sub Controle()

If txtbox_Ingangsdatum.Text = "" Then
    msgbox "Geen ingangs datumvermeld"
    Exit Sub
End If
  
  
If fixedfee_nee.Value = True And txtbox_fixedfee.Text = "" Then
    msgbox "Vul Email adres in"
    Exit Sub
End If
If spoedtoeslag_nee.Value = True And txtbox_spoedtoeslag.Text = "" Then
    msgbox "Spoedtoeslag berekenen is leeg"
    Exit Sub
End If
If afrondingwerkuren_anders.Value = True And txtbox_afrondingwerkuren.Text = "" Then
    msgbox "afronding werkuren voor storingen"
    Exit Sub
End If
If kleinmateriaal_nee.Value = True And txtbox_afrondingwerkuren.Text = "" Then
    msgbox "klein materiaal berekenen"
    Exit Sub
End If
If aanmeldingsprocedure_ja.Value = True And txtbox_aanmeldingsprocedure.Text = "" Then
    msgbox "specifieke aanmeldingsprocedure ontbreekt"
    Exit Sub
End If
If webportal_ja.Value = True And txtbox_webportal.Text = "" Then
    msgbox "webportal ontbreekt"
    Exit Sub
End If
If digitaal_ja.Value = True And txtbox_digitaal.Text = "" Then
    msgbox "Emailadres ontbreekt"
    Exit Sub
End If
If contractopdrachtnummer_ja.Value = True And txtbox_contractopdrachtnummer.Text = "" Then
    msgbox "contractopdrachtnummer"
    Exit Sub
End If
If opdrachtnummerstoring_ja.Value = True And txtbox_opdrachtnummerstoring.Text = "" Then
    msgbox "opdrachtnummer ontbreekt"
    Exit Sub
End If
'Let op maandaat bedrag aanpassen!
If opdrachtnummerPOH_ja.Value = True And txtbox_opdrachtnummerPOH.Text = "" Then
    msgbox "opdrachtnummer nodig voor factuur materialen POH"
    Exit Sub
End If
If proforma_jaklantlayout.Value = True And txtbox_proforma.Text = "" Then
    msgbox "lay-out beschrijving ontbreekt"
    Exit Sub
End If
If termijnproforma_anders.Value = True And txtbox_termijnproforma.Text = "" Then
    msgbox "max. termijn tussen indienen proforma en goedkeur klant ontbreekt"
    Exit Sub
End If


If CDate(Me.txtbox_Ingangsdatum.Text) < Date And Keuzemenu_Akkoord.Value = False Then
    msgbox "Ingangsdatum contract Bevind zic in het verleden. Stuur het bestand naar je leidinggevende."
    Call CDO_Mail_Small_Text
        
End If
End Sub

ik dacht zelf iets met "run" of "Call" maar dan krijg ik meldingen dat ik 'functions' or 'variables' moet gebuiken.
Ook als ik de naam van de module gebruikt krijg ik een melding.


Update

Ondertussen is het mij gelukt om de controle voor het verzenden te plaatsen.

Echter is nu het probleem dat er toch een email wordt gemaakt als er toch een vakje leeg is.

Ik krijg nu wel de melding dat het leeg is maar dan klik ik op 'OK' en dan maakt hij vervolgens weer een email.

Ik heb nu dit.

Code: 
Private Sub versturen_Click()

    Run (Controle)
    
    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
    Dim strto As String
    Dim strbody As String
    Dim cell As Range

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

    Set Sourcewb = ActiveWorkbook
    Sheets("overdrachtformulier2").Copy
    Set Destwb = ActiveWorkbook
    With Destwb
    FileExtStr = ".xlsm": FileFormatNum = 52
    End With

   
    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "overdrachtformulier"

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            For Each cell In ThisWorkbook.Sheets("lijstemail").Range("F1:F6")
                If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "ja" Then
                    If strto = "" Then strto = stro & ";"
                    strto = strto & cell.Value & ";"
                End If
            Next cell
            
            .To = strto
            .CC = ""
            .BCC = ""
            .Subject = "overdrachtformulier"
            For Each cell In ThisWorkbook.Sheets("lijstemail").Range("D1:D60")
        strbody = strbody & cell.Value & vbNewLine
    Next
             .Body = strbody
            .Attachments.Add Destwb.FullName
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

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


Wat is een handige manier dat eerst de controle wordt uigevoerd en mocht hier een probleem zijn dat er dan geen email wordt gemaakt?
 
Laatst bewerkt:
Maak er een functie van die een Boolean terug geeft:
Code: 
Function ControleOk() As Boolean

    ControleOk = False

    If txtbox_Ingangsdatum.Text = "" Then
        MsgBox "Geen ingangsdatum vermeld."
        Exit Function
    End If
      
    If fixedfee_nee.Value = True And txtbox_fixedfee.Text = "" Then
        MsgBox "Vul Email adres in."
        Exit Function
    End If
    
    If spoedtoeslag_nee.Value = True And txtbox_spoedtoeslag.Text = "" Then
        MsgBox "Spoedtoeslag berekenen is leeg."
        Exit Function
    End If
    
    If afrondingwerkuren_anders.Value = True And txtbox_afrondingwerkuren.Text = "" Then
        MsgBox "Afronding werkuren voor storingen."
        Exit Function
    End If
    
    If kleinmateriaal_nee.Value = True And txtbox_afrondingwerkuren.Text = "" Then
        MsgBox "Klein materiaal berekenen."
        Exit Function
    End If
    
    If aanmeldingsprocedure_ja.Value = True And txtbox_aanmeldingsprocedure.Text = "" Then
        MsgBox "Specifieke aanmeldingsprocedure ontbreekt."
        Exit Function
    End If
    
    If webportal_ja.Value = True And txtbox_webportal.Text = "" Then
        MsgBox "Webportal ontbreekt."
        Exit Function
    End If
    
    If digitaal_ja.Value = True And txtbox_digitaal.Text = "" Then
        MsgBox "Emailadres ontbreekt."
        Exit Function
    End If
    
    If contractopdrachtnummer_ja.Value = True And txtbox_contractopdrachtnummer.Text = "" Then
        MsgBox "Contractopdrachtnummer."
        Exit Function
    End If
    
    If opdrachtnummerstoring_ja.Value = True And txtbox_opdrachtnummerstoring.Text = "" Then
        MsgBox "Opdrachtnummer ontbreekt."
        Exit Function
    End If
    
    'Let op maandaat bedrag aanpassen!
    If opdrachtnummerPOH_ja.Value = True And txtbox_opdrachtnummerPOH.Text = "" Then
        MsgBox "Opdrachtnummer nodig voor factuur materialen POH."
        Exit Function
    End If
    
    If proforma_jaklantlayout.Value = True And txtbox_proforma.Text = "" Then
        MsgBox "Layout beschrijving ontbreekt."
        Exit Function
    End If
    
    If termijnproforma_anders.Value = True And txtbox_termijnproforma.Text = "" Then
        MsgBox "Maximum termijn tussen indienen proforma en goedkeur klant ontbreekt."
        Exit Function
    End If
    
    
    If CDate(Me.txtbox_Ingangsdatum.Text) < Date And Keuzemenu_Akkoord.Value = False Then
        MsgBox "Ingangsdatum contract bevindt zich in het verleden. Stuur het bestand naar je leidinggevende."
        Call CDO_Mail_Small_Text
        Exit Function
    End If
    
    ControleOk = True
End Function

De regel Run (Controle) verander je dan in:
Code: 
If Not ControleOk Then Exit Sub

NB:
Tevens je teksten gecorrigeerd.
 
Laatst bewerkt:
edmoor zei:
Maak er een functie van die een Boolean terug geeft:

De regel Run (Controle) verander je dan in:


NB:
Tevens je teksten gecorrigeerd.
Klik om te vergroten...

Ed.

heel erg bedankt voor de tip.

De Boolean truc werkt inderdaad om allerlei functie achter elkaar te zetten. :)

hier mee heb ik wat grote stappen kunnen zetten om alle eindjes aan elkaar te knopen.

Heel erg bedankt!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan