macro voor tab blad 1 op te slaan in een nieuw excel werkmap

[davylenders123]

Beste forum gebruikers,

De macro hieronder slaat een werkmap op in een bepaal map en beveligd de werkmap met een wachtwoord.
Mailt dan het werkblad door naar 2 personen.

Ik zou nu willen dat hij het werkblad 1 opslaat in een nieuwe werkmap zodat hij de nieuwe werkmap kan mailen.

Het is eigenlijk de bedoeling dat ik enkel het eerste tab blad kan mailen en de andere tab bladen zouden niet mee mogen omdat de personen die de mails krijgen die gegevens niet mogen zien.

Hoe moet ik hier aan beginnen.
Heb al eens gekeken op de site van ron de bruine maar geraak er niet uit.

Moest iemand een oplossing weten om van het eerste werkblad een pdf te maken dat dan wordt door gemaild is ook goed.
De pdf creator die we gebruiken op het werk is "black ice colorplus ts pdf"

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 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

ActiveSheet.Unprotect Password:="1230"
    Cells.Select
    Selection.Locked = True
    Selection.FormulaHidden = False
    Range("E11").Select
    ActiveSheet.Protect Password:="1230", DrawingObjects:=True, Contents:=True, Scenarios:=True

ActiveWorkbook.SaveAs Filename:=("T:\Mag-Data\Mit pc\davy\uren magazijn\reeds doorgestuurd" & "\Dagstaat Magazijniers " & Format(DateValue([uren!B1]), "dd-mm-yyyy") & ".xls")
stpath = "T:\Mag-Data\Mit pc\davy\uren magazijn\reeds doorgestuurd" 'locactie waar bijlage staat
stsubject = "Dagstaat van de magaziniers"
vamsg = "Anja ." & vbCrLf & _
"Bij deze stuur ik u de uren van de magazijniers.," & vbCrLf & _
      "Met Vriendelijke Groeten"

'mailbody voorzien van gegevens
stfilename = "Dagstaat Magazijniers .xls" 'Bestandsnaam
stattachment = ("T:\Mag-Data\Mit pc\davy\uren magazijn\reeds doorgestuurd" & "\Dagstaat Magazijniers " & Format(DateValue([uren!B1]), "dd-mm-yyyy") & ".xls")
vaRecipients = VBA.Array("mijn@mail.be", "mijnmail@hotmail.com") '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

 

[geep1980]

Hoop dat dit een beetje is wat je zoekt

Bekijk bijlage TestenMail.zip

 

[davylenders123]

Hoop dat dit een beetje is wat je zoekt

Bekijk bijlage 124191

Bij module 2 blijft hij hangen .

Het gele kleurd hij geel bij de foutmelding en het rode dat selecteerd hij bij de foutmelding

Option Explicit

'The code below are used by the macros in the other two modules
'Do not change the code in the functions in this module

[COLOR="darkorange"]Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As [/COLOR]String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                [COLOR="darkred"]Type:=xlTypePDF, _[/COLOR]                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function