VBA Code to open PDF file using LastModifiedDate

[shi6oonz]

Dears

i have macro to save specific Range of Cells as PDF, each time i run this macro It save the Range of Cells As new file with new last modified date in Specific Folder

what i need is to chose a date from DTPicker1 and Click search and the command button will show me the File with selected date from DTPicker1
so can the user search for the history report in any date entered

please see the below Pic :

https://s1.gifyu.com/images/HISTORY-MREXCEL.png
the QA is how to link the FILE Date with the DTPicker1 & command Button

so when i chose the date ( 7/22/2018 ) then click search
it will show me PDF file with 7/22/2018 Date

Or if you have similar way to do this please help me ...

thanks in advance

[Kenneth Hobs]

In a Module paste:

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function




Function GetFileNamesByModifiedDate(a, d As Date)
Dim b As Variant, c As Variant, i As Long, j As Long
b = a
ReDim c(LBound(a) To UBound(a))
j = -1
For i = LBound(a) To UBound(a)
b(i) = FileDateTime(a(i))
If DateSerial(Year(b(i)), Month(b(i)), Day(b(i))) = d Then
j = j + 1
c(j) = a(i)
End If
Next i
ReDim Preserve c(LBound(c) To j)
GetFileNamesByModifiedDate = c
End Function




In the Userform paste and replace the path value in variable p:

Private Sub CommandButton1_Click()
Dim a, b, p$
p = "C:\Users\Ken\Dropbox\Excel\pdf\"
a = aFFs(p & "*.pdf", "/o-d", True)
If Not IsArray(a) Then Exit Sub

b = GetFileNamesByModifiedDate(a, CDate(DTPicker1.Value))
If Not IsArray(a) Then GoTo EndNow
MsgBox Join(b, vbLf)

EndNow:
Unload Me
End Sub

[shi6oonz]

Ohhh we are very Close to do it .. but the File did not open
only filename show on dilogbox pls see below :

22622

really appreciate your support

[shi6oonz]

Ohhh we are very Close to do it .. but the File did not open
only filename show on dilogbox pls see below :

22622

really appreciate your support

After Clicking OK the File didn't open
and the VBA Do Unload me function ..

[Kenneth Hobs]

This just opens the first file.
'MsgBox Join(b, vbLf)
Shell "cmd /c " & """" & b(1) & """", vbNormalFocus

[shi6oonz]

This just opens the first file.
'MsgBox Join(b, vbLf)
Shell "cmd /c " & """" & b(1) & """", vbNormalFocus
Dear , it will open First File of the folder ? Even if i select a specific date ?

[Kenneth Hobs]

No, it opens the newest file with that date. That is easy to see by testing.

Often I will have more than one PDF file each day. If you want to open all PDF files with that date, that is easily done as well.

[shi6oonz]

No, it opens the newest file with that date. That is easy to see by testing.

Often I will have more than one PDF file each day. If you want to open all PDF files with that date, that is easily done as well.
This is what I need really, thanks i will test the code tomorrow.
appreciate your support

[shi6oonz]

No, it opens the newest file with that date. That is easy to see by testing.

Often I will have more than one PDF file each day. If you want to open all PDF files with that date, that is easily done as well.

Dear What Script Should i Select from Reference ?

22637


Private Sub CommandButton1_Click() Dim a, b, p$
p = "C:\Laboratory _Tracking _System\Reports\CAUSTIC\"
a = aFFs(p & "*.pdf", "/o-d", True)
If Not IsArray(a) Then Exit Sub

b = GetFileNamesByModifiedDate(a, CDate(DTPicker1.Value))
If Not IsArray(a) Then GoTo EndNow
MsgBox Join(b, vbLf)
Shell "cmd /c " & """" & b(1) & """", vbNormalFocus


EndNow:
Unload Me
End Sub

I put This Into my button and show me the error Above

[Kenneth Hobs]

Did you put the code from Post #2 into a Module as I explained?

[shi6oonz]

Yes Dear

[shi6oonz]

This in Module #28


'Set extraSwitches, e.g. "/ad", to search folders only.'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function




Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function








Function GetFileNamesByModifiedDate(a, d As Date)
Dim b As Variant, c As Variant, i As Long, j As Long
b = a
ReDim c(LBound(a) To UBound(a))
j = -1
For i = LBound(a) To UBound(a)
b(i) = FileDateTime(a(i))
If DateSerial(Year(b(i)), Month(b(i)), Day(b(i))) = d Then
j = j + 1
c(j) = a(i)
End If
Next i
ReDim Preserve c(LBound(c) To j)
GetFileNamesByModifiedDate = c
End Function




Command button


Private Sub CommandButton1_Click() Dim a, b, p$
p = "C:\Laboratory _Tracking _System\Reports\CAUSTIC\"
a = aFFs(p & "*.pdf", "/o-d", True)
If Not IsArray(a) Then Exit Sub

b = GetFileNamesByModifiedDate(a, CDate(DTPicker1.Value))
If Not IsArray(a) Then GoTo EndNow
MsgBox Join(b, vbLf)
Shell "cmd /c " & """" & b(1) & """", vbNormalFocus


EndNow:
Unload Me
End Sub

[shi6oonz]

Dear I Found The Problem
if i select a date , and on that date there are Tow Files on the same Date ,the code run perfect, and the newest file will open
but if i select a date , and there is only on file on that date i select, the code will give me SubScript out of range ....

[shi6oonz]

Did you put the code from Post #2 into a Module as I explained?

i Changed Shell "cmd /c " & """" & b(1) & """", vbNormalFocus to Shell "cmd /c " & """" & b(0) & """", vbNormalFocus
and it works perfectly :friends::friends::friends::friends:

i will keep use your code and i hope no other problem will face me :crying:
thanks a lot my Dear i really appreciate your help

[Kenneth Hobs]

That should work fine except for special cases. e.g. An ampersand character in the filename. We can fix that like this:

Shell "cmd /c " & """" & Replace(b(0), "&", "^&") & """", vbNormalFocus

I changed the initialization of j as well.

Function GetFileNamesByModifiedDate(a, d As Date)
Dim b As Variant, c As Variant, i As Long, j As Long
b = a
ReDim c(LBound(a) To UBound(a))
j = 0
For i = LBound(a) To UBound(a)
b(i) = FileDateTime(a(i))
If DateSerial(Year(b(i)), Month(b(i)), Day(b(i))) = d Then
c(j) = a(i)
j = j + 1
End If
Next i
ReDim Preserve c(LBound(c) To j)
GetFileNamesByModifiedDate = c

End Function

[shi6oonz]

That should work fine except for special cases. e.g. An ampersand character in the filename. We can fix that like this:

Shell "cmd /c " & """" & Replace(b(0), "&", "^&") & """", vbNormalFocus

I changed the initialization of j as well.

Function GetFileNamesByModifiedDate(a, d As Date)
Dim b As Variant, c As Variant, i As Long, j As Long
b = a
ReDim c(LBound(a) To UBound(a))
j = 0
For i = LBound(a) To UBound(a)
b(i) = FileDateTime(a(i))
If DateSerial(Year(b(i)), Month(b(i)), Day(b(i))) = d Then
c(j) = a(i)
j = j + 1
End If
Next i
ReDim Preserve c(LBound(c) To j)
GetFileNamesByModifiedDate = c

End Function

Done
it work perfect so far :clap2:
i really don't know how to thank you BRO

[shi6oonz]

That should work fine except for special cases. e.g. An ampersand character in the filename. We can fix that like this:

Shell "cmd /c " & """" & Replace(b(0), "&", "^&") & """", vbNormalFocus

I changed the initialization of j as well.

Function GetFileNamesByModifiedDate(a, d As Date)
Dim b As Variant, c As Variant, i As Long, j As Long
b = a
ReDim c(LBound(a) To UBound(a))
j = 0
For i = LBound(a) To UBound(a)
b(i) = FileDateTime(a(i))
If DateSerial(Year(b(i)), Month(b(i)), Day(b(i))) = d Then
c(j) = a(i)
j = j + 1
End If
Next i
ReDim Preserve c(LBound(c) To j)
GetFileNamesByModifiedDate = c

End Function

Dear how to display msgbox "No files on this date" if i select a date.... ? :dunno

[shi6oonz]

Dear how to display msgbox "No files on this date" if i select a date.... ? :dunno

Guys any idea ?

[Kenneth Hobs]

Private Sub CommandButton1_Click()
Dim a, b, p$
p = "C:\Users\Ken\Dropbox\Excel\pdf\"
a = aFFs(p & "*.pdf", "/o-d", True)
If Not IsArray(a) Then Exit Sub

b = GetFileNamesByModifiedDate(a, CDate(DTPicker1.Value))
If b(0) = "" Then
MsgBox "No file with that date exists"
Else
Shell "cmd /c " & """" & Replace(b(0), "&", "^&") & """", vbNormalFocus
End If

Unload Me
End Sub

[shi6oonz]

Private Sub CommandButton1_Click()
Dim a, b, p$
p = "C:\Users\Ken\Dropbox\Excel\pdf\"
a = aFFs(p & "*.pdf", "/o-d", True)
If Not IsArray(a) Then Exit Sub

b = GetFileNamesByModifiedDate(a, CDate(DTPicker1.Value))
If b(0) = "" Then
MsgBox "No file with that date exists"
Else
Shell "cmd /c " & """" & Replace(b(0), "&", "^&") & """", vbNormalFocus
End If

Unload Me
End Sub

It Works Perfect
Thank you for your time to help :content: