VB Code to save pdf file with different name like (1) (2)

[ateebali]

Dear Sir,
I am using following code link with button, when it click, it save the file with cell value.
I want if the file already exist in folder, it should not replace the file, instead it saved it with extension like 123(1)


Sub PDFActiveSheet()


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ThisWorkbook.Path & "\TCS Style Name " & Range("D16").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

End Sub

 

[Kenneth Hobson]

IF you have Excel 32 bit, put this into a Module and call MakeUnique(your filename here) to build the unique filename.

'This kb article:
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041

'Another sequential filename
'tstav,http://vbaexpress.com/kb/getarticle.php?kb_id=1008

Const Max_Path As String = 260
'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare Function PathYetAnotherMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal pszPath As String, _
  ByVal pszShort As String, _
  ByVal pszFileSpec As String _
  ) As Boolean

'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare Function PathMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal cchMax As Long, _
  ByVal pszTemplate As String, _
  ByVal pszLongPlate As String, _
  ByVal pszDir As String _
  ) As Boolean
  
Function fMakeAnotherUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathYetAnotherMakeUniqueName(vUniqueName, StrConv(vFolder, vbUnicode), _
    StrConv(vShortTemplate, vbUnicode), StrConv(vLongTemplate, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeAnotherUnique = vUniqueName
  End If
End Function

Function MakeAnotherUnique(filespec As String) As String
  MakeAnotherUnique = fMakeAnotherUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function fMakeUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathMakeUniqueName(vUniqueName, Max_Path, StrConv(vShortTemplate, vbUnicode), _
    StrConv(vLongTemplate, vbUnicode), StrConv(vFolder, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeUnique = vUniqueName
  End If
End Function

Function MakeUnique(filespec As String) As String
  MakeUnique = fMakeUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function GetFileName(filespec As String) As String
  Dim p1 As Integer, p2 As Integer
  p1 = InStrRev(filespec, "\")
  p2 = Len(filespec) - p1
  GetFileName = Mid$(filespec, p1 + 1, p2)
End Function

Function GetFolderName(filespec As String) As String
  Dim p1 As Integer
  p1 = InStrRev(filespec, "\")
  GetFolderName = Left$(filespec, p1)
End Function

 

[ateebali]

Sir, thanks but its not working

 

[smozgur]

You need a helper function. Please try following to see if it helps.

Sub PDFActiveSheet()
Dim PDFFileName As String


    PDFFileName = GeneratedFileName(ThisWorkbook.Path & "\TCS Style Name " & Range("D16").Value, 0)


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFFileName, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, OpenAfterPublish:=True


End Sub


Function GeneratedFileName(fileName As String, i As Integer)
Dim testFileName As String
    testFileName = fileName
    If i <> 0 Then
        testFileName = fileName & " (" & i & ")"
    End If
    GeneratedFileName = testFileName
    If Dir(testFileName & ".pdf", vbNormal) > "" Then
        GeneratedFileName = GeneratedFileName(fileName, i + 1)
    End If
    
End Function

 

[ateebali]

Thanks a lot, this is perfectly done

 

[ateebali]

Dear Sir
Can you help me again please?
This code giving me error again;

Sub SavePDFActiveSheet()Dim PDFFileName As String




    PDFFileName = GeneratedFileName(ThisWorkbook.Path & "\PDF " & Range("T3").Value, 0)




    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFFileName, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, OpenAfterPublish:=True




End Sub




Function GeneratedFileName(fileName As String, i As Integer)
Dim testFileName As String
    testFileName = fileName
    If i <> 0 Then
        testFileName = fileName & " (" & i & ")"
    End If
    GeneratedFileName = testFileName
    If Dir(testFileName & ".pdf", vbNormal) > "" Then
        GeneratedFileName = GeneratedFileName(fileName, i + 1)
    End If
    
End Function

Run Time Error '52'
Bad File name or number