Hi everybody, I am trying to use this code to Save a sheet in a specific folder and mail it, but it's not working.
I have a workbook with lot's of sheets and some buttons to select the sheets and ail them, and at the same time give them the appropriate name and save as PDF and XLSX, as pdf works like a charme, but XLSX is not working, what am I doing wrong?
I have a workbook with lot's of sheets and some buttons to select the sheets and ail them, and at the same time give them the appropriate name and save as PDF and XLSX, as pdf works like a charme, but XLSX is not working, what am I doing wrong?
Code:
Sub IO_LIJST_TO_EXCEL_AND_MAIL_IT()
Dim FileName As String
Dim rw As Long, i As Long, lastRow As Long, compLastRow&
Dim cel As Range
Dim mainWS As Worksheet, ws As Worksheet
Dim ans As String, lr As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If MsgBox("REVISIE ECHT VERHOGEN?", vbYesNo, "WEL OF NIET?") = vbYes Then
ans = Format(Now, "dd-mmm-yy")
MsgBox "DE REVISIE IS VERHOOGD"
Sheets("REV. RELEASE").Select
lr = Range("B" & Rows.Count).End(xlUp).Row + 1
Range("B" & lr).Value = ans
FileName = RDB_Create_EXCEL(Source:=Sheets(Array("IO")), FixedFilePathName:="",OverwriteIfFileExist:=True,OpenEXCELAfterPublish:=False)
Else
MsgBox "DE REVISIE IS NIET VERHOOGD"
FileName = RDB_Create_EXCEL2(Source:=Sheets(Array("IO")), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenEXCELAfterPublish:=False)
End If
If FileName <> "" Then
RDB_Mail_EXCEL_Outlook FileNameEXCEL:=FileName, _
StrTo:="", _
StrCC:="", _
StrBCC:="", _
StrSubject:="IO lijst", _
Signature:=True, _
Send:=False, _
StrBody:="<body>Beste,<br>" & _
"Zie de toegevoegde EXCEL bestand met de laatste IO lijst." & _
"<br><br>" & "</body>"
Else
MsgBox "Het was niet mogelijk om het bestand te maken, mogelijke redenen:" & vbNewLine & _
"Microsoft Add-in is niet geinstalleerd" & vbNewLine & _
"Het pad om de bestand op te slaan in arg 2 is niet correct" & vbNewLine & _
"U heeft het bestaande EXCEL bestand niet willen overschrijven"
End If
Application.DisplayAlerts = False
End Sub
-----------------------------------------------------------------------------------------------------------------------------------------------
Function RDB_Create_EXCEL(Source As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenEXCELAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim FName As Variant
Dim wb As Workbook
Dim k As Integer, lr As Long
'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 EXCEL
FileFormatstr = "EXCEL Files , *.xlsx"
Sheets("REV. RELEASE").Select
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("B" & lr).Select
ActiveCell.Offset(0, -1).Select
FName = Application.GetSaveAsFilename("G:\Roosendaal\SISe ZW Roosendaal Software\Backups\Vopak Europoort\Allen Bradley\Fase3 OS33-3\Tagdatabase\VERZONDEN_LIJSTEN\Fase3_OS33-3_IO_LIJST_AB_" & Selection & "_" & Format(Date, "yyyymmdd"), _
filefilter:=FileFormatstr, _
Title:="Create EXCEL")
'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 EXCEL
'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 EXCEL
On Error Resume Next
Source.SaveAs FName 'Save file
Source.Close
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(FName) <> "" Then RDB_Create_EXCEL = FName
End If
End Function
-----------------------------------------------------------------------------------------------------------------------------------------------
Function RDB_Create_EXCEL2(Source As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenEXCELAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim FName As Variant
Dim wb As Workbook
Dim NewShtName As String
Dim k As Integer, lr As Long
'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 EXCEL
FileFormatstr = "EXCEL Files , *.xlsx"
Sheets("REV. RELEASE").Select
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("B" & lr).Select
ActiveCell.Offset(0, -1).Select
FName = Application.GetSaveAsFilename("G:\Roosendaal\SISe ZW Roosendaal Software\Backups\Vopak Europoort\Allen Bradley\Fase3 OS33-3\Tagdatabase\VERZONDEN_LIJSTEN\Fase3_OS33-3_IO_LIJST_AB_" _
& Selection & "_" & Format(Date, "yyyymmdd") & "_" & "Intern", _
filefilter:=FileFormatstr, _
Title:="Create EXCEL")
'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 EXCEL
'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 EXCEL
On Error Resume Next
Source.SaveAs FName 'Save file
Source.Close
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(FName) <> "" Then RDB_Create_EXCEL2 = FName
End If
End Function
Last edited:
