VBA code, file overwriting

[mateo93]

Hello,
I have problem with overwriting file. When I create first pdf, data in outlook cant upload. When i trying do this second time and pfd file exist in folder, data show in outlok.


Sub SaveAsPDFandSend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xPath As String

Set xSht = Sheet12

xPath = "C:\Users\361mwrzos\OneDrive - Sonova\Desktop\worksheet to pdf" 'here "workshet to pdf" is the destination folder to save the pdf files
xFolder = xPath & "\" & Sheet12.Range("O1") & ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "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
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

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.From = Sheet20.Range("C2")
.To = Sheet20.Range("D2") 'poprawic na c15 zeby podalo adres email w outlook
.CC = ""
.Subject = "Invoice " & Sheet12.Range("O1")
.Body = "Dear Sir od Madame" & vbCrLf & _
"In the attachment you will find cross charge invoice " & Sheet12.Range("O1") & "." & vbCrLf & _
"Let us know if any issues." & vbCrLf & _
"Best Regards,"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub

 

[Logit]

.
I had to change the path here in order to properly test the code. You'll need to edit for your purposes there. Hopefully this code is sufficiently
annotated showing the changes made.

Option Explicit

Sub SaveAsPDFandSend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xPath As String


Set xSht = Sheet1

xPath = "C:\Users\jimga\Desktop" 'here "workshet to pdf" is the destination folder to save the pdf files
xFolder = xPath & "\" & Sheet1.Range("A1").Value & ".pdf"
    
    If Len(Dir(xFolder)) > 0 Then
        xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
        vbYesNo + vbQuestion, "File Exists")
        
        On Error Resume Next
            If xYesorNo = vbYes Then
                Kill xFolder
            Else
                MsgBox "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
            
        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

Set xUsedRng = xSht.UsedRange

    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        'Save as PDF file
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
        
        'Create Outlook email
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        
        With xEmailObj
            '.Display
            '.From = Sheets("Sheet1").Range("C1").Value
            .SentOnBehalfOfName = Sheets("Sheet1").Range("C1").Value
            .To = Sheet1.Range("D1").Value 'poprawic na c15 zeby podalo adres email w outlook
            .CC = ""
            .Subject = "Invoice " & Sheet1.Range("E1").Value
            .Body = "Dear Sir od Madame" & vbCrLf & _
            "In the attachment you will find cross charge invoice " & Sheet1.Range("E1") & "." & vbCrLf & _
            "Let us know if any issues." & vbCrLf & _
            "Best Regards,"
            .Attachments.Add xFolder
        
            'If DisplayEmail = False Then
                '.Send
            'End If
            .Display
            
        End With
    Else
        MsgBox "The active worksheet cannot be blank"
        Exit Sub
    End If
    
End Sub

 

[mateo93]

hello, thank You but still first time when I create new pdf i cant see data in outlook. WHen file is created and i run macro again, data is visible in Outlook.

 

[mateo93]

Sorry, but its OK, Thank You very much!

 

[Logit]

Great. Glad to help.

 

[rhombus4]

Is it possible to resize the Sheet to fit on PDF or maybe turn PDF into landscape before it saves it