Incremental number for saved files

[crujazz]

Dear all,

I'm new here and trying to find a fix for my problem.






i've used a code what was explained here (see title) on the forum and i'm wondering if the same code could be used for pdf files instead of xls/xlm etc. The code works perfectly for me aslong as it is a workbook/sheet.

Could someone point me in the roght direction?
I've inserted an example

[p45cal]

Your file doesn't include the calling line for GetNewSuffix. This is where you need to make the changes, not in GetNewSuffix.
In the article (here (http://www.vbaexpress.com/kb/getarticle.php?kb_id=1008)) there is a calling sub:Sub CreateNewFileName()
'--------------------------------------------------------------------------------
'Produces an incremental FileName (if name is 'Data' it creates Data-1.xls)
'Builds a suffix always one greater than the max suffix of any other potentially
'existing files that have the same 'root' name, e.g. if 'Data.xls' and 'Data-2.xls'
'exist, it creates Data-3.xls
'Helps to avoid overwrite old files (among other uses)
'--------------------------------------------------------------------------------
Dim newFileName As String, strPath As String
Dim strFileName As String, strExt As String
strPath = "C:\AAA\" 'Change to suit
strFileName = "Data" 'Change to suit
strExt = ".xls" 'Change to suit
newFileName = strFileName & "-" & GetNewSuffix(strPath, strFileName, strExt) & strExt
MsgBox "The new FileName is: " & newFileName
'Save copy
ActiveWorkbook.SaveCopyAs strPath & newFileName
End Subchange:
strExt = ".xls"
to:strExt = ".pdf"
Adjust other things as indicated in the code, then change:ActiveWorkbook.SaveCopyAs strPath & newFileName
to something along the following lines (this was recorded by me and tweaked; you should do this yourself so that the right things are exported to pdf):
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= strPath & newFileName, Quality:= xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[crujazz]

@p45cal

Thank you for the reply but after testing the code creates a pdf of the active worksheet. What i'm trying to acomplish is:

first a routine creates an email, attach one or multiple pdf files
(the pdf files are mentioned in the worksheet)

second the code copies the original files (base for the attachment) to another directory (as a backup)

third the next time i send an email with an attachment, the code must check (after the attaching) if there's an existings pdf file, if so not overwrite it but increment the pdf file with a suffix

Point 1 and 2 are working fine but point 3 doesn't.

[p45cal]

I was wrong, you do have a calling line.
You're using FileCell.value which is a full path and file name, you need to split it into separate path and file name. Check out the likes of:
mid(FileCell.Value,instrrev(FileCell.Value,"\")+1)
for the filename (you'll still have to strip off the extension .pdf)
and:
left(FileCell.Value,instrrev(FileCell.Value,"\"))
for the path which includes the trailing \ (you may not need this if you're saving to a different path).

[crujazz]

No worries,

but in what part of the code do i put the split? In the function or sub?

[p45cal]

No worries,

but in what part of the code do i put the split? In the function or sub?
Change this bit: For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
strPath = Left(FileCell.Value, InStrRev(FileCell.Value, "\"))
strExt = ".pdf"
strFileName = Mid(FileCell.Value, InStrRev(FileCell.Value, "\") + 1)
strFileName = Left(strFileName, Len(strFileName) - Len(strExt))
newFileName = strFileName & "_" & GetNewSuffix(strPath, strFileName, strExt) & strExt
FSO.CopyFile Source:=FileCell.Value, Destination:=ToPath & "\" & newFileName
End If
End If
Next FileCell

[crujazz]

The code works the way i wanted it. Very happy right now!

@p45cal, thank you very much for your time and patient.

Regards

[crujazz]

Last thing before i close this question, the suffix doesn't count :( it hangs on _1.....

[p45cal]

The file should be saved in the same location as the function is looking for older/previous versions of the file.
If you look for the highest suffix in one location and save the file to another, the next time it looks in the the first location it won't see any new files.
So
Destination:=ToPath & "\" & newFileName
could/should be:
Destination:=StrPath & newFileName

[crujazz]

The file with the function aslong with the documents are in the same folder, the sub is checking and creates only xxx_1.pdf and doesn't add 1 integer extra .

I've changed your suggestion but it keeps giving me the dame result....

[p45cal]

The file with the function aslong with the documents are in the same folder,
The excel file containing the function can be anywhere - it's not relevant.



the sub is checking and creates only xxx_1.pdf and doesn't add 1 integer extra .
I've changed your suggestion but it keeps giving me the dame result....The folder being checked for versions must be the same one as the one the new file is being saved to.
I will check later by trying this.

[crujazz]

Thnx in advance p45cal...

[p45cal]

It works here; here's my slightly altered version of the function:
Function GetNewSuffix(ByVal strPath As String, ByVal strName As String, ByVal strExt As String) As Integer
Dim strFile As String, strSuffix As String, intMax As Integer
On Error GoTo ErrorHandler
'File's name
strFile = Dir(strPath & strName & "*" & strExt)
Do While strFile <> ""
'File's suffix starts 2 chars after 'root' name (right after the "-")
strSuffix = Mid(strFile, Len(strName) + 2, Len(strFile) - Len(strName) - Len(strExt) - 1)
'FileName is valid if 1st char after name is "_" and suffix is numeric with no dec point
'Skip file if "." or "," exists in suffix
If Mid(strFile, Len(strName) + 1, 1) = "_" And CSng(strSuffix) >= 0 And _
InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
'Store the max suffix
If CInt(strSuffix) >= intMax Then intMax = CInt(strSuffix)
End If
NextFile:
strFile = Dir
Loop
GetNewSuffix = intMax + 1
Exit Function

ErrorHandler:
If Err Then
Err.Clear
Resume NextFile
End If
End Function

[crujazz]

Is it a possibility that strFile = Dir(strPath & strName & "*" & strExt) won't work for me cause it refers to Filecell in my case?

I've add an zipfile containing 2 pdf (analyses and historic reports) and the exel sheet with code.

[p45cal]

At first glance of your code, you haven't done as I suggested in msg#9;
You still have:
Destination:=newFileName
instead of:
Destination:=StrPath & newFileName

still looking at it though…

[p45cal]

I also recommend you stick with the purple code in msg#13.
It worked after both those changes in your file.

[crujazz]

One happy peep overhere, much appreciated for your info

It worked

[snb]

or:

Sub M_snb()
MsgBox F_volgnummer_snb("G:\OF\", "adressen", "xls")
End Sub

Function F_volgnummer_snb(c00, c01, c02)
F_volgnummer_snb = UBound(Split(CreateObject("wscript.shell").exec("cmd /c dir " & c00 & c01 & "*." & c02 & "/b").stdout.readall, vbCrLf)) + 2
End Function

[crujazz]

Hi all,

The code works fine but the last problem i encounter is when i send more than one email all the emails get the CC of the last email.

In my worksheet i have a column D (to) and column F (cc). If i mark column E (email sending routine is depending of column E) all the emails get CC of the last marked cell... Is that common?

[p45cal]

The code works fine but the last problem i encounter is when i send more than one email all the emails get the CC of the last email.
<snip>... Is that common? It is, the way you've written it!

comment-out or delete:'Accountmanagers
'For Each cell1 In sh.Columns("F").Cells.SpecialCells(xlCellTypeConstants)
' If cell1.Value Like "?*@?*.?*" And cell1.Offset(0, 1).Value = "j" Then
' strCC = cell1.Value & ";"
' End If
'Next cell1
then add the purple below: If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "x" And Application.WorksheetFunction.CountA(rng) > 0 Then
If cell.Offset(, 2).Value Like "?*@?*.?*" And cell.Offset(0, 3).Value = "j" Then
strCC = cell.Offset(, 2).Value & ";"
End If
Set OutMail = OutApp.CreateItem(olMailItem)
(untested)