Opgelost VBA in Excel: Actieve werkblad kopieren en Mailen

Dit topic is als opgelost gemarkeerd
Status
Niet open voor verdere reacties.
G

gpiket7

Gebruiker
Lid geworden
25 jul 2008
Berichten
169
Goedenavond,

Ik ben een UrenRegistratie aan het maken in Excel, zie bijgevoegd bestand.
Nu ben ik aan het proberen om met VBA een en ander voor mekaar te krijgen.
Er zijn nu 3 knoppen, de bovenste "Aanmaken Nieuwe Week" werkt precies zoals ik hem wil hebben.
Echter de onderste 2 knoppen "Doormailen Urenregistratie" zouden een combinatie moeten worden onder 1 knop.

De bovenste "Doormailen Urenregistratie" maakt netjes een nieuw document (van de actieve werkblad) en verwijderd de knoppen.
Maar dit is geen tijdelijk opgeslagen document wat gemaild wordt.

De onderste "Doormailen Urenregistratie" maakt wel een tijdelijk bestand, voegt het gehele excel als bijlage toe en mailt deze.

Wat ik nu juist wil is een combinatie van deze 2, het is juist de bedoeling dat alleen het actieve werkblad wordt gemaild, waar de knoppen zijn verwijderd.
Of nog liever als xlsx, dus zonder Macro's en zonder meldingen.
(Toevoeging, wel de lay-out blijven behouden)

Dus je drukt op de knop, de active sheet wordt een nieuw bestand, zonder de knoppen en wordt direct doorgestuurd naar het opgegeven mailadres.

Heeft iemand een idee wat ik moet wijzigen, want ik ben helemaal nieuw in VBA
 

Bijlagen

Kan je die niet beter als PDF versturen?
Of moet de ontvanger er weer in werken?
 
Test deze maar eens:
Code: 
Sub MailSheet()
    Dim MailFile As String
   
    Sheets("BLANCO").Copy
    ActiveSheet.Shapes.Range(Array("CommandButton1", "CommandButton2", "CommandButton3")).Delete
    MailFile = Environ("tmp") & "\mail" & Format(Now, "ddmmyyyyhhmmss") & ".xlsx"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs MailFile
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Range("D3")
        .Subject = "Urenregistratie " & Range("C2") & " " & Range("B4") & " " & Range("C4")
        .Body = "Hallo " & Range("C3") & "," & vbNewLine & vbNewLine & _
        "Hierbij mijn uren van afgelopen week." & vbNewLine & vbNewLine & _
        "Met vriendelijke groet, " & vbNewLine & Range("C2")
        .Attachments.Add MailFile
        .Display
    End With
    Kill MailFile
End Sub
 
Laatst bewerkt:
Bedankt, ik heb hem net werkend via een andere code.

Code: 
Private Sub CommandButton2_Click()
    'Do not forget to change the email ID
    'before running this code
    
    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim FileExt As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim FileFormat As Variant
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Wb1 = ThisWorkbook
    ActiveSheet.Copy
    ActiveSheet.Shapes.Range(Array("CommandButton1")).Select
    Selection.Delete
    ActiveSheet.Shapes.Range(Array("CommandButton2")).Select
    Selection.Delete
    Set Wb2 = ActiveWorkbook
    
    'Below code will get the File Extension and
    'the file format which we want to save the copy
    'of the workbook with the active sheet.
    
    With Wb2
        If Val(Application.Version) < 12 Then
             FileExt = ".xls": FileFormat = -4143
        Else
            Select Case Wb1.FileFormat
            Case 51: FileExt = ".xlsx": FileFormat = 51
            Case 52:
                If .HasVBProject Then
                    'FileExt = ".xlsm": FileFormat = 52
                    FileExt = ".xlsx": FileFormat = 51
                Else
                    FileExt = ".xlsx": FileFormat = 51
                End If
            Case 56: FileExt = ".xls": FileFormat = 56
            Case Else: FileExt = ".xlsb": FileFormat = 50
            End Select
        End If
    End With
Application.DisplayAlerts = False
    'Save your workbook in your temp folder of your system
    'below code gets the full path of the temporary folder
    'in your system
    
    TempFilePath = Environ$("temp") & "\"

    'Now append a date and time stamp
    'in your new file
    
    TempFileName = [C2] & "_" & [B4] & "_" & [C4]

    'Complete path of the file where it is saved
    FileFullPath = TempFilePath & TempFileName & FileExt
    
    'Now save your currect workbook at the above path
    Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
    
    'Now open a new mail
    
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    
    On Error Resume Next
    With NewMail
        .To = Range("D3")
        .CC = ""
        .BCC = ""
        .Subject = "Urenregistratie " & Range("C2") & " " & Range("B4") & " " & Range("C4")
        .Body = "Hallo " & Range("C3") & "," & vbNewLine & vbNewLine & _
        "Hierbij mijn uren van afgelopen week." & vbNewLine & vbNewLine & _
        "Met vriendelijke groet, " & vbNewLine & _
        "" & Range("C2")
        .Attachments.Add FileFullPath '--- full path of the temp file where it is saved
        .Send   'or use .Display to show you the email before sending it.
    
    MsgBox ("Je urenregistratie is verzonden. Bedankt!")
    
    End With
    On Error GoTo 0
    
    'Since mail has been sent with the attachment
    'Now close and delete the temp file from the
    'temp folder
    Wb2.Close SaveChanges:=False
    Kill FileFullPath
    
    'set nothing to the objects created
    Set NewMail = Nothing
    Set OlApp = Nothing
    
    'Now set the application properties back to true
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Dat kan veel beter en eenvoudiger; heb je de code van @edmoor wel getest?
 
Hi,

Had ik nog niet gedaan, nu wel want is inderdaad wat minder complex.
Op zich werkt deze wel, maar nu werd steeds het blad "BLANCO" gekopieerd, niet de actieve, dat kon ik zelf wijzigen.
Alleen de file name wordt nu ""mailddmmyyyyhhmmss" en dat krijg ik niet gewijzigd.
Dat zou ik graag willen zoals in de andere code: TempFileName = [C2] & "_" & [B4] & "_" & [C4]

Code: 
Private Sub CommandButton2_Click()
    Dim MailFile As String
 
    ActiveSheet.Copy
    ActiveSheet.Shapes.Range(Array("CommandButton1", "CommandButton2")).Delete
    MailFile = Environ("tmp") & "\mail" & Format(Now, "ddmmyyyyhhmmss") & ".xlsx"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs MailFile
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Range("D3")
        .Subject = "Urenregistratie " & Range("C2") & " " & Range("B4") & " " & Range("C4")
        .Body = "Hallo " & Range("C3") & "," & vbNewLine & vbNewLine & _
        "Hierbij mijn uren van afgelopen week." & vbNewLine & vbNewLine & _
        "Met vriendelijke groet, " & vbNewLine & Range("C2")
        .Attachments.Add MailFile
        .Display
    End With
    Kill MailFile
End Sub
 
Code: 
application.displayalerts = false
Wb2.SaveAs Environ$("temp") & "\" & [C2] & "_" & [B4] & "_" & [C4], 51

Application.displayalerts = True kun je vergeten in de code, gaat automatisch weer op True.
 
Laatst bewerkt:
Moet ik dit stuk code vervangen door jou stuk code?
Code: 
MailFile = Environ("tmp") & "\mail" & Format(Now, "ddmmyyyyhhmmss") & ".xlsx"

Dit stukje heb ik geen weet van "Application.displayalerts = True kun je vergeten in de code, gaat automatisch weer op True."
Ik zie hem in de code ook 2x staan, 1x als False en 1x als True
 
1). Die regel verwijderen.
2). In de code staat het inderdaad 2x de laatste op True verwijderen (overbodig).
 
Ik heb er nu dit van gemaakt, maar krijg dan een foutmelding: "Fout 424 tijdens uitvoering: Object vereist"

Code: 
Private Sub CommandButton2_Click()
    Dim MailFile As String
  
    ActiveSheet.Copy
    ActiveSheet.Shapes.Range(Array("CommandButton1", "CommandButton2")).Delete
    Application.DisplayAlerts = False
    Wb2.SaveAs Environ$("temp") & "\" & [C2] & "_" & [B4] & "_" & [C4], 51
    ActiveWorkbook.SaveAs MailFile
    ActiveWorkbook.Close
  
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Range("D3")
        .Subject = "Urenregistratie " & Range("C2") & " " & Range("B4") & " " & Range("C4")
        .Body = "Hallo " & Range("C3") & "," & vbNewLine & vbNewLine & _
        "Hierbij mijn uren van afgelopen week." & vbNewLine & vbNewLine & _
        "Met vriendelijke groet, " & vbNewLine & Range("C2")
        .Attachments.Add MailFile
        .Display
    End With
    Kill MailFile
End Sub
 
Maak er dit van:
Code: 
Mailfile = Environ$("temp") & "\" & [C2] & "_" & [B4] & "_" & [C4]
    ActiveWorkbook.SaveAs mailfile,51
 
Laatst bewerkt:
Als ik dat wijzig dan krijg ik de melding: "Compileerfout: Verwacht: instructie-einde"
 
Heb het juist aangepast, is ook niet makkelijk vanaf mobiel.
 
Ik ben al lang blij dat er iemand mee denkt, ik krijg nu weer de "Fout 424 tijdens uitvoering: Object vereist"
Als ik dan Foutopsporing start maakt hij de regel
Code: 
.To = Range("D3")
geel gearceerd.
 
Je activeworkbook is gesloten om gegevens uit cel D3 te halen.
Maak een variabele aan voor je het werbook sluit en gebruik die variabele achter .To
 
Ik heb geen idee wat ik moet doen, ik heb die andere code die wel werkte wat aangepast en korter gemaakt.
Deze werkt nu, dus ik ben tevreden op deze manier. Bedankt voor jullie hulp.

Code: 
Private Sub CommandButton2_Click()

    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim FileExt As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim FileFormat As Variant
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Wb1 = ThisWorkbook
    
    ActiveSheet.Copy
    ActiveSheet.Shapes.Range(Array("CommandButton1", "CommandButton2")).Delete
        Set Wb2 = ActiveWorkbook
    
    With Wb2
        FileExt = ".xlsx": FileFormat = 51
    End With
        Application.DisplayAlerts = False

    TempFilePath = Environ$("temp") & "\"
    TempFileName = [C2] & "_" & [B4] & "_" & [C4]
    FileFullPath = TempFilePath & TempFileName & FileExt
    Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
    
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    
    On Error Resume Next
    With NewMail
        .To = Range("D3")
        .CC = ""
        .BCC = ""
        .Subject = "Urenregistratie " & Range("C2") & " " & Range("B4") & " " & Range("C4")
        .Body = "Hallo " & Range("C3") & "," & vbNewLine & vbNewLine & _
        "Hierbij mijn uren van afgelopen week." & vbNewLine & vbNewLine & _
        "Met vriendelijke groet, " & vbNewLine & _
        "" & Range("C2")
        .Attachments.Add FileFullPath
        .Display
    
    MsgBox ("Je urenregistratie is verzonden. Bedankt!")

    Wb2.Close SaveChanges:=False
    Kill FileFullPath

End With
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan