Macro to Save PDF (some adjustments needed)

[Andrei]

Hello,

I have a macro that Saves to Pdf an invoice and gives the user the possiblity to choose the folder.

ISSUE 1: The macro works for ordinary folder, but if user selects "Desktop" it gives error 91: "Object Variable or With block variable not set".

ISSUE 2: Also when user hits "Cancel" in the Brower for folder section, it gives error 1004: "Document not Saved. the docoment may be open or an error may have been encountered when saving". How can i do to not have this message and to just cancel ?

This is the code:

Sub savetopdf()
s = Range("S3").Value
v = Range("D10").Value

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        GetFolder & "\" & "F" & s & "-" & v & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
        :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub


Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Alegeti un folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Thanks !

 

[Andrei]

Hi,

I solved the issues, but for the first issue i didn't found an elegant solution. So if someone knows how to make possible saving on desktop please let me know.

My new code is the following:

Sub savetopdf()
s = Range("S3").Value
v = Range("D10").Value

On Error GoTo errCheck

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        GetFolder & "\" & "F" & s & "-" & v & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
        :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
      
errCheck:
        If Err.Number = 1004 Then
           Exit Sub
        ElseIf Err.Number = 91 Then
        MsgBox "Cannot save on Desktop"
       End If
End Sub


Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Alegeti un folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[PeterB]

Hi Andrei,

I don't think there is any general reason why you cannot write to the desktop. I have tested your code on my Windows 8.1 PC and it writes fine.

My guess would be that the user's IT department has set up specific security restrictions for that PC which as far as I am aware you are not going to be able to bypass with your VBA. All you can do, is what you have done, which is to show an error message.

Thanks,

Peter

 

[lohithsriram]

Hi Andrei,

I have revised your code to resolve both the issues. Please check and let me know, if you need any other changes with this.

Sub savetopdf()
Dim strFilePath As String
s = Range("S3").Value
v = Range("D10").Value


On Error GoTo errCheck
    strFilePath = GetFolder()
    If Not strFilePath = "" Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            strFilePath & "\" & "F" & s & "-" & v & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
            :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End If
    Exit Sub
errCheck:
        MsgBox "Error while saving the PDF"
'        If Err.Number = 1004 Then
'           Exit Sub
'        ElseIf Err.Number = 91 Then
'        MsgBox "Cannot save on Desktop"
'       End If
End Sub


Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Alegeti un folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.self.Path
Set oFolder = Nothing
End Function

 

[Andrei]

Hello, lohithsriram,

Thanks a lot for revising the code, i tested it and it works perfect !

You know how it is: after you manage to make something you want more and so on

Now i was thincking how to do that if user saves the file in one Folder where another file with the same name exists the macro to let him know and to give the possiblity to replace the file or to save it with another name (ex. F0001 ... (1) )

I looked un on the internet and managed to find this (the text with " ' "), but it doesn't work )

Sub savetopdf()
s = Range("S3").Value
v = Range("D10").Value
'Dim StrPath As String, StrName As String, Result

'StrPath = GetFolder & "\"
'StrName = "F" & s & "-" & v

On Error GoTo errCheck

'While Dir(StrPath & StrName & ".pdf") <> ""
    'Result = InputBox("ATENTIE - A file already exists with the name:" & vbCr & _
      '"F" & s & "-" & v & vbCr & _
      '"You may edit the filename or continue without editing." _
      & vbCr & vbTab & vbTab & vbTab & "Proceed?", "File Exists", StrName)
    'If Result = vbCancel Then Exit Sub
    'If StrName = Result Then GoTo Overwrite
    'StrName = Result
'Wend

'Overwrite:
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        GetFolder & "\" & "F" & s & "-" & v & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
        :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
     
errCheck:
        If Err.Number = 1004 Then
        Exit Sub
        ElseIf Err.Number = 91 Then
        MsgBox "Nu puteti salva pe Desktop. Alegeti un alt folder !", vbExclamation, "Salvare PDF"
        Resume
        ElseIf Err.Number = -2147024773 Then
        MsgBox "Nu puteti salva aici. Alegeti un alt folder !", vbExclamation, "Salvare PDF"
        Resume
        End If
End Sub


Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Alegeti un folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[lohithsriram]

Hi Andrei,

There seems no built in way to prompt the replace option window using the ExportAsFixedFormat command. However, you can validate it by checking the existence of the file before you export it. There is a way described in the below link. Please go through and let me know, if you need any hands.


http://www.mrexcel.com/forum/excel-...rqriting-files-visual-basic-applications.html