macro aanpassen die via lotus mailt

[davylenders123]

Beste

Bij ons op het werk hebben ze het lumineuze idee gehad om van mail programma te veranderen.
We hadden lotus notus en ze schakelen nu over naar outlook 2003.

Ik heb een hele hoop excel bestanden op ons netwerk staan waar een macro in is verwerkt die mailt
Deze macro's zijn overal wel wat anders want het een bestand slaagt het bestandje ergens op en stuurd het dan door en ander slacht dan weer niet op , nog een andere wist en deel voor doorsturen.
En zo heeft elk wel een andere functie erbij .

Is er op een makkelijke manier een mogelijkheid om al mijn macro's om te bouwen zodat ze met outlook werken ?

Heb hieronder 1 macro toegevoegd die mailt via lotus notus.

Const EMBED_ATTACHMENT As Long = 1454
Const vaCopyTo As Variant = "" 'copy mailen naar: "adres"

Sub mail()


 Dim vaRecipients As Variant
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim noAttachment As Object

If [invulblad!F1] = "" Then MsgBox "Je hebt geen week nummer ingevuld in cel F1 !": Exit Sub
Sheets("interim").Select
If vbNo = MsgBox("Ben je wel zeker dat je die mail wil verzenden", vbYesNo) Then Exit Sub
If vbNo = MsgBox("Heb je lotus notus open staan?", vbYesNo) Then Exit Sub


ActiveWorkbook.SaveAs Filename:=("S:\86\Mag-Data\Mit pc\davy\planning randstad\planning al door gemaild" & "\randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls")
stpath = "S:\86\Mag-Data\Mit pc\davy\planning randstad\planning al door gemaild" 'locactie waar bijlage staat
stsubject = "randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op  " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls" _

vamsg = "Goedemorgen, " & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"Bij deze stuur ik jullie de planning, aangepaste planning  voor de volgende dagen. " & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"Hier staat in hoeveel magazijniers we nodig hebben voor welke ploeg. " & vbCrLf & vbCrLf & _
"Het kan zijn dat je 2 planningen aankrijgt op 1 nacht/ avond , dan moet je de planning nemen die als onderwerp de laatste datum en uur heeft. " & vbCrLf & vbCrLf & _
"De planning zal voor de zelfde week gewoon worden aangevuld als er extra mensen worden gevraagd, daarom moet je steeds de laatste nemen die is doorgestuurd naar jullie. " & vbCrLf & vbCrLf & _
"Je moet wel rekening houden met de week nummer die zit verwerkt in het onderwerp en in de naam van het excel bestand." & vbCrLf & vbCrLf & _
      "Met Vriendelijke Groeten" & vbCrLf & vbCrLf & _
      "De Hoofdmagazijniers"


'mailbody voorzien van gegevens
stfilename = "Dagstaat Magazijniers .xls" 'Bestandsnaam
stattachment = ("S:\86\Mag-Data\Mit pc\davy\planning randstad\planning al door gemaild" & "\randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls")
vaRecipients = VBA.Array("test1@test1.be", "test2@test2.be", "test@test.be") 'mailadressen("eerste ontvanger" , "tweede ontvanger", enz.)

                  'Bepaal de Lotus Notes COM's Objecten.
                  Set noSession = CreateObject("Notes.NotesSession")
                  Set noDatabase = noSession.GETDATABASE("", "")
                  
                  'Als Lotus Notes niet open is open dan het mail-gedeelte ervan.
                  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
                 
                  'Maak de e-mail en de bijlage.
                  Set noDocument = noDatabase.CreateDocument
                  Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
                  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stattachment)
                                 
                  'Voeg de gegevens toe aan de gemaakte e-mail eigenschappen.
                  With noDocument
                    .Form = "Memo"
                    .SendTo = vaRecipients
                    .CopyTo = vaCopyTo
                    .Subject = stsubject
                    .Body = vamsg
                    .SaveMessageOnSend = True
                    .PostedDate = Now()
                   .Send 0, vaRecipients
                  End With
                 
                          
                  'Verwijder objecten uit het geheugen.
                  Set noEmbedObject = Nothing
                  Set noAttachment = Nothing
                  Set noDocument = Nothing
                  Set noDatabase = Nothing
                  Set noSession = Nothing
                  
                  MsgBox "De e - mail is correct verstuurd ", vbInformation



End Sub

 

[HSV]

Zoek eens op het forum naar mailen of iets dergelijks (Outlook).

Enkele objectleden:

with CreateObject("Outlook.Application").CreateItem(0)
  .to = ""
  .cc = ""  .
  .Bcc = [EMAIL="hsv@hsv.com"]hsv@hsv.com[/EMAIL]
  .body = "tekst"
  .Subject = "Dit is een test"
  .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
  .htmlbody = ""
  .display
  .send
end with

Je kunt het gelijk aanpassen in je code.
Helaas weet ik ook niet alle objectleden van Outlook.
Of ze overeenkomen met je ander programma weet ik dus niet.

 

[davylenders123]

Hsv

Bedankt voor u snel reactie weer Top:thumb:.

Heb u code al eens snel geplakt en die werkt al , kan hier zeker al een stuk verder mee.
Dank hiervoor.

Heb enkel nog een vraagje , hoe kan ik bij to meerder mail adressen ingeven zodat de mail naar meerder mensen gestuurd wordt ?
Heb al geprobeerd met , ertussen te zetten maar lukt niet.
Heb ook al "dddd@dddd.be","ddd@fff.be" geprobeerd maar werkt ook niet.

Zal weer wel heel simpel zijn maar ik ben hier niet al te goed in

 

[HSV]

Davy,

Als ze onder elkaar staan in kolom A.

Dim allenamen As String
    allenamen = Join(Application.Transpose(Columns(1).SpecialCells(xlCellTypeConstants)), "; ")
 With CreateObject("Outlook.Application").CreateItem(0)
  .Bcc = allenamen
  .Subject = "alle namen gescheiden door puntkomma"
  .Display

End With

 

[davylenders123]

Hsv

Bedankt door punt komma werkt het wel .:thumb:

 

[davylenders123]

Sorry heb nog een klein probleempje.
Heb de code nu aangepast zodat ze zou moeten worden voor 1 bestand.
Ze doet ook alles zoals het zou moeten maar stuurd enkel geen body mee in de mail.
Deze blijft gewoon leeg.

Wat moet ik nog aanpassen om dit voor elkaar te krijgen ?

Sub mailnieuwe()




If [invulblad!F1] = "" Then MsgBox "Je hebt geen week nummer ingevuld in cel F1 !": Exit Sub
Sheets("interim").Select
If vbNo = MsgBox("Ben je wel zeker dat je die mail wil verzenden", vbYesNo) Then Exit Sub



ActiveWorkbook.SaveAs Filename:=("H:\My Documents\randstad\reeds doorgemaild" & "\randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls")


With CreateObject("Outlook.Application").CreateItem(0)
  .to = "ccc@def.be;aaa@ddd.be"
  .cc = ""
  .Bcc = ""
  .body = "Hi there"
  .Subject = "randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op  " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls"
  .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
  .htmlbody = ""
  .display
  .send
End With



                  
                  MsgBox "De e - mail is correct verstuurd ", vbInformation



End Sub

 

[HSV]

Gebruik jij Outlook als je mailprogramma?
Anders werkt het niet lees ik hier en daar op het net.
Ook over Servise Pack 3, maar ik wordt van de ene pagina naar de ander geslingerd.
Misschien dat jij hier iets meer tijd in wil steken.

Overigens werkt het prima bij mij Davy.

 

[davylenders123]

Ja wij gebruiken outlook 2003.
Dit is in een fusion sessie van citrix.

Ik heb ook een code van ron de bruine geprobeerd en daar komt de body wel in de mail te staan.

Sub Mail_allSheets_Array()
'Working in Excel 2000-2013maild meer dan een scheet
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    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 sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("interim", "invulblad")).Copy
    End With

    'Close temporary Window
    TempWindow.Close

    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            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 With

    '    'Change all cells in the worksheets to values if you want
    '    For Each sh In Destwb.Worksheets
    '        sh.Select
    '        With sh.UsedRange
    '            .Cells.Copy
    '            .Cells.PasteSpecial xlPasteValues
    '            .Cells(1).Select
    '        End With
    '        Application.CutCopyMode = False
    '        Destwb.Worksheets(1).Select
    '    Next sh

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    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 = "dfh@fdhfdl.be;dfhddf@ogf.be"
            .cc = ""
            .Bcc = ""
            .Subject = "Test 1"
            .body = "Hi there test 1"
            .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

 

[davylenders123]

Heb het klaar gekregen met de volgende code

Sub mailoutlook()


If [invulblad!F1] = "" Then MsgBox "Je hebt geen week nummer ingevuld in cel F1 !": Exit Sub
Sheets("interim").Select
If vbNo = MsgBox("Ben je wel zeker dat je de mail wil verzenden", vbYesNo) Then Exit Sub
If vbNo = MsgBox("Heb je outlook open staan ?", vbYesNo) Then Exit Sub

ActiveWorkbook.SaveAs Filename:=("H:\My Documents\Mag_data\planning randstad\planning al door gemaild" & "\randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls")


  With CreateObject("Outlook.Application").createitem(olMailItem)
  .To = "dhes@pl.be"
  .cc = ""
  .Subject = "randstad Planning PostNL Cargo Belgie Turnhout Week " & Sheets("invulblad").Cells(1, 6).Value & " Doorgestuurd op  " & Format(Now, "dd-mm-yyyy hh" & "u " & "mm") & ".xls"
  .body = Replace("Goedemorgen,##Bij deze stuur ik jullie de planning, aangepaste planning  voor de volgende dagen.#Zie voor  nadere informatie de bijlage.#Hier staat in hoeveel magazijniers we nodig hebben voor welke ploeg.#Het kan zijn dat je 2 planningen aankrijgt op 1 nacht/ avond , dan moet je de planning nemen die als onderwerp de laatste datum en uur heeft.#De planning zal voor de zelfde week gewoon worden aangevuld als er extra mensen worden gevraagd, daarom moet je steeds de laatste nemen die is doorgestuurd naar jullie.#Je moet wel rekening houden met de week nummer die zit verwerkt in het onderwerp en in de naam van het excel bestand.##Met Vriendelijke Groeten##De Hoofdmagazijniers###", "#", vbCr)
  .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
  .Send
  End With
  
  MsgBox "De e - mail is correct verstuurd ", vbInformation
End Sub

Bedankt voor je hulp :thumb:

 

[HSV]

Mooi dat het gelukt is.

Hier nog een kleine aanpassing voor je.

.Attachments.Add ThisWorkbook.FullName