Excel file opslaan als PDF, Doortellen en emailen

Status
Niet open voor verdere reacties.

Billyb24

Nieuwe gebruiker
Lid geworden
6 jan 2018
Berichten
1
Goedendag!

Ik heb al met veel artikelen op dit forum mijn Excel skills kunnen verbeteren. Het vraagstuk wat ik nu heb kan ik helaas niet oplossen door middel van de zoekfunctie. Ik heb een Excel file waarin ik facturen maak. Hier heb ik met macro's ervoor gezorgd dat de factuurnummers automatisch doortellen, de factuur wordt opgeslagen als Excel en PDF, ik kan hem automatisch 1 of 2 keer kan printen. Hier heb ik dan 3 knoppen voor gemaakt te weten:

* Opslaan als Excel & PDF
* Opslaan & Printen
* Opslaan & 2x printen

Echter wil ik nu graag ook dat de file automatisch naar de klant gemaild wordt en hier wordt het lastig. Ik had een VBA code gevonden die dit kon, maar toen ik deze invoegde werkte het doortellen van de factuurnummers niet meer en kreeg ik een foutmelding. Hoe kan ik onderstaande code werkend krijgen? Uiteindelijk wil ik de volgende knoppen hebben:

* Opslaan als Excel & PDF
* Opslaan & Printen
* Opslaan & 2x printen
* Opslaan en emailen als PDF
* Opslaan, printen en emailen als PDF

In alle gevallen moet het factuurnummer +1 verder worden geteld.

Alvast bedankt voor het meedenken! :thumb:

Code:
Sub VolgFact()
Option Explicit
Application.ScreenUpdating = False
Range("I24").Value = Range("I24").Value + 1
Range("B24").Value = Date
Application.ScreenUpdating = True
End Sub

Sub OpslBestand()
Application.ScreenUpdating = False
Dim NieuwFact As Variant
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String

'kopiëren document als nieuwe factuur
ActiveSheet.Copy
NieuwFact = "\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".xlsx"
ActiveWorkbook.SaveAs NieuwFact, FileFormat:=xlOpenXMLWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")
    s(0) = ThisWorkbook.FullName
    
    If FSO.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = FSO.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")
            
            '//Export to PDF with new File Path
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:="\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".pdf"
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If
    
    Set FSO = Nothing
ActiveWorkbook.Close

VolgFact
Application.ScreenUpdating = True
End Sub

Sub OpslMailen()
Application.ScreenUpdating = False
Dim NieuwFact As Variant
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Dim objOl As Outlook.Application
Dim objMail As Object

'kopiëren document als nieuwe factuur
ActiveSheet.Copy
NieuwFact = "\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".xlsx"
ActiveWorkbook.SaveAs NieuwFact, FileFormat:=xlOpenXMLWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")
    s(0) = ThisWorkbook.FullName
    
    If FSO.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = FSO.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")
            
            '//Export to PDF with new File Path
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:="\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".pdf"
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If
    
    Set FSO = Nothing
    
    Set objOl = Outlook.Application 'Start Outlook
    Set objMail = objOl.CreateItem(0)
    'Maakt e-mailbericht aan. olMailItem kan ook worden
    'vervangen door 0 (code voor e-mailitem)

    '////////////////////////////////////////////////////
    'Dit stukje is voor Outlook 2007 voor het vastleggen
    'van de afzender van een e-mailbericht. Hiervoor moet
    'in VBA wel worden verwezen (Extra, Verwijzingen) naar
    'minimaal Microsoft Outlook 12 Object Library.
    Dim objAccount As Outlook.Account
    For Each objAccount In objOl.Session.Accounts
        If objAccount.DisplayName = "Naam Outlook-account" Then
            Set objMail.SendUsingAccount = objAccount
        End If
    Next
    Set objAccount = Nothing
    '////////////////////////////////////////////////////
    'Gebruik eventueel deze optie in oudere versies van Outlook
    'waarbij een e-mail wordt verzonden namens een ander e-mailadres.
    objMail.SentOnBehalfOfName = "Test Naam <test@testnaam.nl>"
    '////////////////////////////////////////////////////

    With objMail
        .To = Range("F11") 'Deze moet worden aangepast
        .Subject = "Factuur" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & "
        .Body = "Hier plaatst u de inhoud van het bericht"
        '.HTMLBody = "<HTML><P>TEST</P></HTML>"
        .NoAging = True
        .Attachments.Add "\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".pdf" 'De locatie van de bijlage
        .Display
    End With

    Set objMail = Nothing
    Set objOl = Nothing
ActiveWorkbook.Close

VolgFact
Application.ScreenUpdating = True
End Sub


Public Sub OpslPrinten()
Application.ScreenUpdating = False
Dim NieuwFact As Variant
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String

'kopiëren document als nieuwe factuur
ActiveSheet.Copy
NieuwFact = "\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".xlsx"
ActiveWorkbook.SaveAs NieuwFact, FileFormat:=xlOpenXMLWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")
    s(0) = ThisWorkbook.FullName
    
    If FSO.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = FSO.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")
            
            '//Export to PDF with new File Path
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:="\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".pdf"
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If
    
    Set FSO = Nothing
ActiveSheet.PrintOut
ActiveWorkbook.Close

VolgFact
Application.ScreenUpdating = True
End Sub

Public Sub OpslPrinten2()
Application.ScreenUpdating = False
Dim NieuwFact As Variant
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String

'kopiëren document als nieuwe factuur
ActiveSheet.Copy
NieuwFact = "\\192.168.2.***locatie file***l\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".xlsx"
ActiveWorkbook.SaveAs NieuwFact, FileFormat:=xlOpenXMLWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")
    s(0) = ThisWorkbook.FullName
    
    If FSO.FileExists(s(0)) Then
        '//Change Excel Extension to PDF extension in FilePath
        s(1) = FSO.GetExtensionName(s(0))
        If s(1) <> "" Then
            s(1) = "." & s(1)
            sNewFilePath = Replace(s(0), s(1), ".pdf")
            
            '//Export to PDF with new File Path
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:="\\192.168.2.***locatie file***\" & Range("I24") & " " & Range("C24") & " " & Range("F10").Value & ".pdf"
        End If
    Else
        '//Error: file path not found
        MsgBox "Error: this workbook may be unsaved.  Please save and try again."
    End If
    
    Set FSO = Nothing
ActiveSheet.PrintOut , Copies:=2
ActiveWorkbook.Close

VolgFact
Application.ScreenUpdating = True
End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan