How Do I Change The Date Format in VBA Code

[nathandavies]

Hi All, I have some Code which works apart from when I want to name a file with the date (IE Advice Note - 20/04/2018.pdf) it keeps crashing. i know the reason why because your not allowed to use "/" in the name of a file but how do you change it in the coding to show like the following Advice Note_20-04-2018.pdf
I have put my code below for your viewing so you can see how i've created the code.

Thanks in Advance



Sub PrintAdviceNote()

ProjectRootFolder = Sheets("RootFolder").Range("B5").Value
JobNumber = Sheets("Summary").Range("CJobNumber").Value
CSiteName = Sheets("Summary").Range("CSiteName").Value
CCompanyName = Sheets("Summary").Range("CCompanyName").Value
AdviceNote = Sheets("AdviceNote").Range("DelNote").Value




Sheets("AdviceNote").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

With Sheets("AdviceNote")
.Visible = True
.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=ProjectRootFolder & Application.PathSeparator & _
CCompanyName & Application.PathSeparator & _
JobNumber & " " & CSiteName & Application.PathSeparator & _
AdviceNote & "_" & Date & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
.Visible = True
End With
Sheets("Summary").Select
ActiveWorkbook.Save
End Sub

[Paul_Hossler]

This is function from my utility belt that 'cleans' file and folder names by replacing illegal characters with an underscore

There are some other characters besides \ that are not allowed, so I thought I'd make it as robust as possible

I also decided that I wanted spaces replaced with underscores also, but that's changeable

It doesn't run very often so performance isn't an issue so I tried to make it as straight forward as possible




Function fileCleanName(s As String, Optional ThisIsAFolder As Boolean = False) As String
Dim s1 As String, s2 As String
Dim i As Long


s1 = vbNullString
s2 = Trim(s)

If Not ThisIsAFolder Then
For i = 1 To Len(s2)
Select Case Mid(s2, i, 1)
Case Chr(0) To Chr(32), "<", ">", ":", """", "/", "\", "|", "?", "*"
s1 = s1 & "_"
Case Else
s1 = s1 & Mid(s2, i, 1)
End Select
Next i

'paths can have / and \
Else
For i = 1 To Len(s2)
Select Case Mid(s2, i, 1)
Case Chr(0) To Chr(32), "<", ">", ":", """", "|", "?", "*"
s1 = s1 & "_"
Case Else
s1 = s1 & Mid(s2, i, 1)
End Select
Next i
End If

Do While InStr(s1, "__") > 0
s1 = Replace(s1, "__", "_")
Loop

fileCleanName = s1
End Function

[nathandavies]

Thanks Paul,

When would i call this function in to action??

Nathan

[Paul_Hossler]

Thanks Paul,

When would i call this function in to action??

Nathan


Just like any other function



Sub PrintAdviceNote()
ProjectRootFolder = Sheets("RootFolder").Range("B5").Value
JobNumber = Sheets("Summary").Range("CJobNumber").Value
CSiteName = Sheets("Summary").Range("CSiteName").Value
CCompanyName = Sheets("Summary").Range("CCompanyName").Value
AdviceNote = Sheets("AdviceNote").Range("DelNote").Value

filenametosave = ProjectRootFolder & Application.PathSeparator
filenametosave = filenametosave & CCompanyName & Application.PathSeparator
filenametosave = filenametosave & JobNumber & " " & CSiteName & Application.PathSeparator
filenametosave = filenametosave & AdviceNote & "_" & Format(Date, "dd-mm-yyyy") & ".pdf"

MsgBox filenametosave


filenametosave = cleanfilename(filenametosave)
MsgBox filenametosave


Sheets("AdviceNote").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

With Sheets("AdviceNote")
.Visible = True
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=filenametosave, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
.Visible = True
End With
Sheets("Summary").Select
ActiveWorkbook.Save
End Sub

Function fileCleanName(s As String, Optional ThisIsAFolder As Boolean = False) As String
Dim s1 As String, s2 As String
Dim i As Long


s1 = vbNullString
s2 = Trim(s)

If Not ThisIsAFolder Then
For i = 1 To Len(s2)
Select Case Mid(s2, i, 1)
Case Chr(0) To Chr(32), "<", ">", ":", """", "/", "\", "|", "?", "*"
s1 = s1 & "_"
Case Else
s1 = s1 & Mid(s2, i, 1)
End Select
Next i

'paths can have / and \
Else
For i = 1 To Len(s2)
Select Case Mid(s2, i, 1)
Case Chr(0) To Chr(32), "<", ">", ":", """", "|", "?", "*"
s1 = s1 & "_"
Case Else
s1 = s1 & Mid(s2, i, 1)
End Select
Next i
End If

Do While InStr(s1, "__") > 0
s1 = Replace(s1, "__", "_")
Loop

fileCleanName = s1
End Function

[nathandavies]

Hi Paul,
i have tried the code and i keep getting an compile error. "Sub or Fuction not Defined"


filenametosave = cleanfilename(filenametosave)

[Bob Phillips]

Should it be


filenametosave = fileCleanName(filenametosave)

[nathandavies]

Thanks xld, I didn’t notice that, I now have the following error "ByRef argument type mismatch"


(filenametosave)

[Bob Phillips]

You need to declare filenametosave as a string variable, as it is undeclared it is being treated as a variant.

[nathandavies]

Thanks for your help, this has worked but is now not saving the PDF in the correct location, i think its because its removing all the "" & "/" from the patch and not the file name only.

[nathandavies]

Ive managed to fix the problem.

Thank you for your help!

[Paul_Hossler]

Hi Paul,
i have tried the code and i keep getting an compile error. "Sub or Fuction not Defined"


filenametosave = cleanfilename(filenametosave)


My fault -- Careless mistake :doh:

I always use Option Explicit for my stuff, but followed your lead and didn't use it since no variables were Dim-ed

Since I couldn't test it, the macro never got a chance to fail:think:

[nathandavies]

Paul, not a problem thank you for you help on this!