Excel Sheet als PDF versturen

[bjack61]

Hallo, Ik heb uit volgend oud onderwerp "Onderwerp: Macro omzetten naar pdf en emaillen vanuit excel" een code gehaald om een sheet uit een excelbestand te versturen.

edmoor had daar als eerste gereageerd en ik heb zijn code gebruikt die perfect werkt als je het e-mail adres in de code plaatst. Ik zou graag de e-mail adressen uit een apart tabblad "DropMail" willen halen zodat de gebruikers zelf e-mailadressen kunnen toevoegen/verwijderen.

Dus "aan" moet dan werken met 1 of meerdere e-mailadressen en "CC" mag ook leeg zijn, of 1 of meerdere e-mailadressen. In bijlage het bestand met op het blad "test" de foutmelding die ik krijg.
Er is iets fout in deze regel: ".To = Join(Application.Transpose(Sheets("DropMail").Cells(3, 1).CurrentRegion), ";")"

De e-mailadressen in het bestand zijn fictief omdat ik toch .display gebruik en niet .send.

mvg Jacky

 

[JEC.]

Probeer het eens zo

.To = Join(Application.Transpose(Sheets("DropMail").Range("A3", Sheets("DropMail").Cells(Rows.Count, 1).End(xlUp))), ";")
.CC = Join(Application.Transpose(Sheets("DropMail").Range("B3", Sheets("DropMail").Cells(Rows.Count, 2).End(xlUp))), ";")

 

[bjack61]

Ok, merci, werkt inderdaad maar als ik maar 1 e-mailadres in de lijst zet werkt het niet, krijg ik weer foutmelding. Waarschijnlijk door de ";"

 

[JEC.]

Dan zo

.To = Join(Application.Transpose(Sheets("DropMail").Range("A3", Sheets("DropMail").Cells(Rows.Count, 1).End(xlUp).Offset(1))), ";")
.CC = Join(Application.Transpose(Sheets("DropMail").Range("B3", Sheets("DropMail").Cells(Rows.Count, 2).End(xlUp).Offset(1))), ";")

 

[bjack61]

We zijn er bijna. Als ik 1 e-mailadres in "Aan" zet en 1 in "CC" werkt het prima. Maar als ik in "CC" geen e-mailadres zet werkt het niet.

 

[HSV]

Sub MailViaPDF_Click()
 Bestand = Environ("TEMP") & "\" & ActiveSheet.Name & ".pdf"
 Set drM = Sheets("DropMail")
 ActiveSheet.ExportAsFixedFormat 0, Bestand
  With CreateObject("Outlook.Application").CreateItem(0)
        .To = Join(Application.Transpose(drM.Range("a3", drM.Range("a3").End(xlDown))), ";")
        .CC = Join(Application.Transpose(drM.Range("b3", drM.Range("b3").End(xlDown))), ";")
        .BCC = ""
        .Subject = "Dit is het onderwerp"
        .Body = "Bij deze het bestand"
        .Attachments.Add Bestand
        '.Send
        .display
  End With
    Kill Bestand
End Sub

 

[cow18]

Sub MailViaPDF_Click2()
   Bestand = Environ("TEMP") & "\" & ActiveSheet.Name & ".pdf"
   Set drM = Sheets("DropMail")
   ActiveSheet.ExportAsFixedFormat 0, Bestand

   With CreateObject("Outlook.Application").CreateItem(0)
      On Error Resume Next                                           'doorgaan bij fout
      With drM.Range("a2").CurrentRegion
         Set c = .Offset(2).Resize(.Rows.Count - 2)                  'bereik met je emailadressen
         If c Is Nothing Then MsgBox "foutje bedankt", vbCritical: Exit Sub   'geen enkel emailadres = einde verhaal
      End With
      For i = 1 To 3                                                 'in een loopje je 3 soorten emails aflopen
         Set c1 = Nothing: Set c1 = c.Columns(i).SpecialCells(xlConstants).Areas(1)
         If Not c1 Is Nothing Then
            If c1.Count = 1 Then s = c1.Value Else s = Join(Application.Transpose(c1), ";")
            Select Case i
               Case 1: .To = s
               Case 2: .cc = s
               Case 3: .bcc = ""                                     'blijkbaar geen BCC gewenst ???
            End Select
         End If
      Next
      On Error GoTo 0

      .Subject = "Dit is het onderwerp"
      .Body = "Bij deze het bestand"
      .Attachments.Add Bestand
      '.Send
      .display
   End With
   Kill Bestand
End Sub

 

[bjack61]

Top Harry, werkt perfect, cow18 heb eerst ff Harry zijne getest, wil zeker die van jou eens proberen. Heb zelf nog wat handige dingen toegevoegd met de MsgBox.
Ik heb wel nog een vraag over het tabblad "DropMail" Als ik deze code ook op andere tabbladen wil gebruiken kan ik rechts naast de andere e-mailadressen een nieuwe reeks maken met andere e-mails. Dit krijg ik aan het werken.

Maar ik zou deze graag onder elkaar zetten zoals in het voorbeeld bestand. Probleem is dan dat hij bij het eerste tabblad Test overal de titel boven de mailadressen toevoegt als mailadres, bv bij CC zet hij CC enz. Best zelf eens testen om te zien wat ik bedoel. Dit is ook logisch uiteraard.

Is dit mogelijk aan te passen door een range op te geven, alleen vind ik hier geen oplossing voor.

Let op! dat jullie niet op JA klikken maar op NEE zodat de mail zich opent en niet gelijk wordt verzonden want de e-mailadressen zijn fictief.

Bedankt alvast !