VBA automatisch opslaan Excel file

Status
Niet open voor verdere reacties.

Glenvz1987

Nieuwe gebruiker
Lid geworden
18 sep 2017
Berichten
4
Beste ,

ik heb reeds volgende code die perfect werkt ( macro ) .

nu wil ik hier een aanpassing in maken dat de macro ipv een PDF file , een excel file opslaat en automatisch doormailt .

reeds 3 weken aan het zoeken en ik vind geen oplossing .

alvast bedankt :)

zie hier de code :

Code:
Option Explicit
 
Sub create_and_email_pdf()
' Author - Philip Treacy  ::   [url]https://www.linkedin.com/in/philiptreacy[/url]
' [url]https://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook[/url]
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook
 
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
 
' *****************************************************
' *****     You Can Change These Variables    *********
 
    EmailSubject = "offerte aanvraag PARTICULIER bomen  Filori-shop "   'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = "info@filori-shop.be"   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ""
    Email_BCC = ""
            
' ******************************************************
     
    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
         
        If .Show = True Then
         
            DestFolder = .SelectedItems(1)
             
        Else
         
            MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
                 
            Exit Sub
             
        End If
         
    End With
 
    'Current month/year stored in H6 (this is a merged cell)
    CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
     
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
                & "_" & CurrentMonth & ".pdf"
 
    'If the PDF already exists
    If Len(Dir(PDFFile)) > 0 Then
     
        If AlwaysOverwritePDF = False Then
         
            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
         
            On Error Resume Next
            'If you want to overwrite the file then delete the current one
            If OverwritePDF = vbYes Then
     
                Kill PDFFile
         
            Else
     
                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
                 
                Exit Sub
         
            End If
 
        Else
         
            On Error Resume Next
            Kill PDFFile
             
        End If
         
        If Err.Number <> 0 Then
         
            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
                 
            Exit Sub
         
        End If
             
    End If
    
    Dim rng As Range, cell As Range, del As Range
 Set rng = Intersect(Range("E22:E935"), ActiveSheet.UsedRange)
 For Each cell In rng
   If (cell.Value) = "" _
   Or (cell.Value) = "0" _
    Then
       If del Is Nothing Then
          Set del = cell
       Else: Set del = Union(del, cell)
       End If
    End If
 Next cell
 On Error Resume Next
 del.EntireRow.Delete
    'Create the PDF
    ActiveSheet.ExportAsFixedFormat Type:=myFile.xlsx, Filename:=xlOpenXMLWorkbook, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=OpenPDFAfterCreating
 
    'Create an Outlook object and new mail message
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
         
    'Display email and specify To, Subject, etc
    With OutlookMail
         
        .Display
        .to = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject & CurrentMonth
        .Attachments.Add PDFFile
                 
        If DisplayEmail = False Then
             
            .Send
             
        End If
         
    End With
     
  
End Sub
 
Laatst bewerkt:
Dit gaat niemand zo lezen. Plaats je code tussen codetags of plaats je document.
 
Hey Edmoor ,

mijn excuses :eek: :)

alvast bedankt !

Code:
Option Explicit
 
Sub create_and_email_pdf()
' Author - Philip Treacy  ::   https://www.linkedin.com/in/philiptreacy
' https://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook
 
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
 
' *****************************************************
' *****     You Can Change These Variables    *********
 
    EmailSubject = "offerte aanvraag PARTICULIER bomen  Filori-shop "   'Change this to change the subject of the email. The current month is added to end of subj line
    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE
    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work
    Email_To = "info@filori-shop.be"   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
    Email_CC = ""
    Email_BCC = ""
            
' ******************************************************
     
    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
         
        If .Show = True Then
         
            DestFolder = .SelectedItems(1)
             
        Else
         
            MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
                 
            Exit Sub
             
        End If
         
    End With
 
    'Current month/year stored in H6 (this is a merged cell)
    CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
     
    'Create new PDF file name including path and file extension
    PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
                & "_" & CurrentMonth & ".pdf"
 
    'If the PDF already exists
    If Len(Dir(PDFFile)) > 0 Then
     
        If AlwaysOverwritePDF = False Then
         
            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
         
            On Error Resume Next
            'If you want to overwrite the file then delete the current one
            If OverwritePDF = vbYes Then
     
                Kill PDFFile
         
            Else
     
                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
                 
                Exit Sub
         
            End If
 
        Else
         
            On Error Resume Next
            Kill PDFFile
             
        End If
         
        If Err.Number <> 0 Then
         
            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
                 
            Exit Sub
         
        End If
             
    End If
    
    Dim rng As Range, cell As Range, del As Range
 Set rng = Intersect(Range("E22:E935"), ActiveSheet.UsedRange)
 For Each cell In rng
   If (cell.Value) = "" _
   Or (cell.Value) = "0" _
    Then
       If del Is Nothing Then
          Set del = cell
       Else: Set del = Union(del, cell)
       End If
    End If
 Next cell
 On Error Resume Next
 del.EntireRow.Delete
    'Create the PDF
    ActiveSheet.ExportAsFixedFormat Type:=myFile.xlsx, Filename:=xlOpenXMLWorkbook, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=OpenPDFAfterCreating
 
    'Create an Outlook object and new mail message
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
         
    'Display email and specify To, Subject, etc
    With OutlookMail
         
        .Display
        .to = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject & CurrentMonth
        .Attachments.Add PDFFile
                 
        If DisplayEmail = False Then
             
            .Send
             
        End If
         
    End With
     
  
End Sub
 
Ok, dank je :)
En moet dat te verzenden Excel bestand dan als Excel document met of zonder macro's worden opgeslagen?
En dan het hele document of 1 of meerdere werkbladen?
 
Laatst bewerkt:
Dat werkt al bij TS ;)
 
reeds 3 weken aan het zoeken en ik vind geen oplossing

Waar heb je gezocht en wat moet er met jouw bestand gebeuren? Een bepaald blad opslaan of het hele bestand moet opgestuurd worden? De code die je gevonden hebt is nogal, hoe zal ik netjes zeggen, achterhaald.
 
Laatst bewerkt:
Hey ,

Ja deze code heb ik ergens gevonden op het net maar het werkt perfect .

De bedoeling is om het hele bestand door te sturen met macro's .

Grt
 
Wijzig dan dit stukje{
Code:
    ActiveSheet.ExportAsFixedFormat Type:=myFile.xlsx, Filename:=xlOpenXMLWorkbook, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=OpenPDFAfterCreating

In dit:
Code:
    ActiveWorkbook.SaveCopyAs "myFile.xlsm"

Waarbij je uiteraard het juiste pad moet opgeven en deze verderop in de code ook als attachment voor de mail meegeeft.

Zie ook:
https://www.rondebruin.nl/win/s1/outlook/amail1.htm
 
Laatst bewerkt:
Hey Edmoor ,

Alvast bedankt he , het opslaan als .xlsm werkt naar behoren , alleen voegt hij dit nu niet meer toe in bijlage via outlook .

Heb je daar toevallig nog een oplossing voor ?

grtz
 
Dat dat moet gebeuren staat ook in mijn vorige bericht.
Je vervangt bij .Attachments.Add PDFFile de PDFFile door de locatie en naam van het document.
 
Het actieve bestand kan je ook zonder VBA direct verzenden. File --> Save & Send --> Send as Attachement.

In VBA lijkt mij dit voldoende
Code:
Sub VenA()
  Dim EmailSubject As String, EmailBody As String
  ThisWorkbook.Save
  EmailSubject = "het onderwerp" 'eventueel aangevuld met gegevens uit het bestand.
  EmailBody = "Beste," & vbLf & vbLf & "Bijgaand het bestandje" 'eventueel aangevuld met gegevens uit het bestand.

  With CreateObject("Outlook.Application").createitem(0)
    .to = "iemand@mail.com"
    .Subject = EmailSubject
    .body = EmailBody
    .Attachments.Add ThisWorkbook.FullName
    .display '.send
  End With
End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan