Just nu i M3-nätverket
Gå till innehåll

Mailto i Excel men gör separata mail


R66

Rekommendera Poster

Hej!

Har hittat det script jag behöver för att skicka mail men det envisas med att lägga enskilda mail istället för ett ruppmail. Ser problematiken men är inte vass nog till att klura ut det själv då denna själv går in och plockar e-post adresser på egna rader...

Vidare så hade jag behövt att den mailar BCC istället för to men det ska jag nog kunna lösa.

Tacksam för hjälp av er experter!

 

 

 

Sub Test1()

 

    Dim OutApp As Object

    Dim OutMail As Object

    Dim cell As Range

 

    Application.ScreenUpdating = True

    Set OutApp = CreateObject("Outlook.Application")

 

    On Error GoTo cleanup

    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        If cell.Value Like "?*@?*.?*" And _

           LCase(Cells(cell.Row, "C").Value) = "yes" Then

 

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next

            With OutMail

                .To = cell.Value

                .Subject = "Reminder"

                .Body = "Dear " & Cells(cell.Row, "A").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

 

Länk till kommentar
Dela på andra webbplatser

Vad är det du vill uppnå? Skicka ett email till många mottagare. 

Om så är fallet har jag svårt att se meningen med att använda excel för att skicka email. Då kan du lika bra klistra in hela kolumnen med emailadresser direkt i emailprogrammets mottagarruta.

 

Tänk även på att du kan få problem med att ditt emailkonto som kan bli spärrat om du skickar väldigt många email på en gång (antal omkring 200 st).

 

Mitt tips är att använda mailchimp och liknande tjänster för massskick av email.

http://mailchimp.com/

Länk till kommentar
Dela på andra webbplatser

Hej och tack för svar!

Meilen ska gå internt och det är en massa villkor som ska uppfyllas för att vara med på maillistan. För att göra denna användarvänlig så ville jag slippa copy/paste på mailadresserna. Mailen är på en intern server.

Länk till kommentar
Dela på andra webbplatser

Ove Söderlund

Om jag tolkar koden rätt så är kolumn C den som styr vilka adresser som ska få utskicket?

Det du behöver göra är att dela upp koden till två delar där del 1 blir att "skanna" igenom listan på adresser och skapa en matris eller sammanfogad textsträng.

Del 2 blir att själva utskicket där raden .To = cell.Value får ändras från cell.Value till din matris eller sammanfogade sträng.

 

En sammanfogad sträng byggs upp med adress & "[den avdelare för flera mailadresser som ditt mailsystem använder]" & nästa adress  ...osv..

Matrisen kan användas till att helt enkelt bygga din sammanfogade sträng om så önskas.

Länk till kommentar
Dela på andra webbplatser

Jag har använt precis samma kod i lite modifierad form. Fungerade bra så länge man använde POP-mail men med IMAP fungerade det inte alls och har ingen aning om varför. Gör som beskrivs i inlägg 4 så kan det nog fungera.

Länk till kommentar
Dela på andra webbplatser

Jag lyckades inte helt att få kläm på det men gjorde en genväg och problemet blev ju löst ändå... Lät en cell få alla mailadresser genom A1&A2&A3 osv... Körde sen en copy/paste och kopierade resultatet till en ny cell med enbart text så att den fick min@mail.se;jag@mail.se osv... Fungerade klockrent..

Inte alls lika proffsigt och skriver detta för att någon kanske har nytat av det en dag?

Tack för all hjälp!!!!!!

 

Information wants to be free, som det hette en gång i tiden...

 

Sub mailto()

    Dim OutApp As Object

    Dim OutMail As Object

    Dim cell As Range

 

Application.ScreenUpdating = False

Sheets("Trigger").Visible = True

 

Sheets("Trigger").Select

    Range("R1").Select

    Selection.Copy

    Sheets("Mail").Select

    Range("B20").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Range("E19").Select

    Application.CutCopyMode = False

    Selection.Copy

    Range("A20").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Application.CutCopyMode = False

 

 

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

 

    On Error GoTo cleanup

    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        If cell.Value Like "?*@?*.?*" Then

 

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next

            With OutMail

                .BCC = cell.Value

                .Subject = "Information från oss"

                .Body = "Till " & Cells(cell.Row, "A").Value _

                      & vbNewLine & vbNewLine & _

                        "Ny information " & vbNewLine & vbNewLine

                

            End With

            On Error GoTo 0

            Set OutMail = Nothing

        End If

    Next cell

Sheets("Trigger").Visible = False

 

cleanup:

    Set OutApp = Nothing

    Application.ScreenUpdating = True

End Sub

Länk till kommentar
Dela på andra webbplatser

Arkiverat

Det här ämnet är nu arkiverat och är stängt för ytterligare svar.

×
×
  • Skapa nytt...