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