Script stops on protected files such as system files - vba

This code stops after a while due to protected files such as system files, "Permission Denied".
Is there a way to modify the code below so that it can handle such protected files or bypass them?
Set objFS=CreateObject("Scripting.FileSystemObject")
WScript.Echo Chr(34) & "Full Path" &_
Chr(34) & "," & Chr(34) & "File Size" &_
Chr(34) & "," & Chr(34) & "File Date modified" &_
Chr(34) & "," & Chr(34) & "File Date Created" &_
Chr(34) & "," & Chr(34) & "File Date Accessed" & Chr(34)
Set objArgs = WScript.Arguments
strFolder = objArgs(0)
Set objFolder = objFS.GetFolder(strFolder)
Go (objFolder)
Sub Go(objDIR)
If objDIR <> "\System Volume Information" Then
For Each eFolder in objDIR.SubFolders
Go eFolder
Next
End If
For Each strFile In objDIR.Files
WScript.Echo Chr(34) & strFile.Path & Chr(34) & "," &_
Chr(34) & strFile.Size & Chr(34) & "," &_
Chr(34) & strFile.DateLastModified & Chr(34) & "," &_
Chr(34) & strFile.DateCreated & Chr(34) & "," &_
Chr(34) & strFile.DateLastAccessed & Chr(34)
Next
End Sub
Then call it from the command line
like this.
c:\test> cscript //nologo myscript.vbs "c:\" > "C:\test\Output.csv"

I've simplified your code (based upon your duplicate question) and without trying to handle errors I can see a problem: objDIR.SubFolders fails when one of the subfolders (such as \System Volume Information) doesn't have permissions to be viewed! You need to use another method on Folder to enumerate the foldernames, combine them with the existing path and then trap the error .GetFolder may cause when you don't have permissions. (I don't have time to code that solution at the moment.)
Option Explicit
Dim objFS
Dim objArgs
Dim strFolder
Dim objFolder
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
WScript.StdOut.WriteLine """Full Path"",""File Size""," & _
"""File Date modified"",""File Date Created""," & _
"""File Date Accessed"""
Set objArgs = WScript.Arguments
strFolder = objArgs(0)
Set objFolder = objFS.GetFolder(strFolder)
Go objFolder
Sub Go(objDIR)
Dim strFile
On Error Resume Next
For Each eFolder in objDIR.SubFolders
Go eFolder
Next
For Each strFile In objDIR.Files
WScript.StdOut.WriteLine """" & strFile.Path & """,""" & _
strFile.Size & """,""" & _
strFile.DateLastModified & """,""" & _
strFile.DateCreated & """,""" & _
strFile.DateLastAccessed & """"
Next
End Sub

VBScript allows error trapping, though not as gracefully as VBA. Try the script below.
On Error Resume Next
'[ ... code ... ]
Dim test_result, divisor
divisor = 1 '' No error
'divisor = 0 '' raise error #11
'divisor = "zero" '' raise a different error
test_result = 2/divisor
If Err.Number = 11 then ''This line must appear at the point error is raised
MsgBox "Handled Error: " & Err.Description
ElseIf Err.Number > 0 then
MsgBox "Error: " & Err.Number & " " & Err.Description
Err.Clear ''if you wanted to proceed clean from here
End If
MsgBox "Result: " & test_result

ensure the process has permissions. see

You can ignore script errors in VBScript by adding
On Error Resume Next
before the part of the code where you want to ignore errors.
The statement to restore the default behavior is
On Error GoTo 0
And just a remark: Method calls in VB and VBScript don't use parenthesis if they appear as a single statement. So the line Go (objFolder) should be replaced by Go objFolder.

Related

MS Access : Records "added" to table, but not "in" table?

In the process of building a Database for my employer.
This has been going mostly smoothly, but I have had an issue where a table "updates" but no record is inserted.
... well sort of not inserted.
I can't actually tell if it is or not. I mean it's not on the table, and my SQL query returns a 0 BUT my VBA SQL query returns a 1 on a record I told it to insert.
Code below
Dim rst As Recordset
Dim wrk As DAO.Workspace
Dim db As DAO.Database
Dim rsp As Integer
Dim uTable As String
Dim inSQL As String
Debug.Print pCurrentCmd
If pCurrentCmd = "NewIT" Then
Set rst = CurrentDb.OpenRecordset("SELECT COUNT(*) FROM tbl_IT_Staff " & _
"WHERE GivenName LIKE " & Chr(34) & Chr(42) & _
Me.txt_GivenName & Chr(42) & Chr(34) & _
" AND Surname LIKE " & Chr(34) & Chr(42) & _
Me.txt_Surname & Chr(42) & Chr(34) & ";")
If rst.Fields(0) > 0 Then
rsp = MsgBox("This person is already in the database!" & _
vbCrLf & "Do you wish to proceed anyway? ", vbYesNo)
Else
Set rst = Nothing
GoTo Finalize
End If
If rsp = 6 Then GoTo Finalize
If rsp = 7 Then GoTo exitSub
Set rst = Nothing
End If
Finalize:
Set wrk = DBEngine.Workspaces(0)
Set db = wrk.OpenDatabase(CurrentDb.Name)
DoEvents
With wrk
On Error GoTo ErrRollback
If pCurrentCmd = "NewIT" Then
uTable = "tbl_IT_Staff"
End If
.BeginTrans
If IsNull(Me.txt_AOR) Then
inSQL = "INSERT INTO " & uTable & " (GivenName, Surname) VALUES (" & _
Chr(34) & Me.txt_GivenName & Chr(34) & Chr(44) & Chr(34) & _
Me.txt_Surname & Chr(34) & ");"
Else
inSQL = "INSERT INTO " & Chr(34) & uTable & Chr(34) & _
" (GivenName, Surname) VALUES (" & Chr(34) & Me.txt_GivenName & _
Chr(34) & Chr(44) & Chr(34) & Me.txt_Surname & Chr(34) & _
Chr(44) & Chr(34) & Me.txt_AOR & Chr(34) & ");"
End If
Debug.Print inSQL
CurrentDb.Execute inSQL, dbFailOnError
Call AuditLogR(DMax("ID", "tbl_IT_Staff"), "NewP", uTable)
.CommitTrans
End With
exitSub:
Exit Sub
Now I created a new test record : Test Tests and ran the code, it went through, and committed the transaction, BUT, no record exists in the table.
Ok, nbd, I made a change (had commented out the auditlog call, so put it back in) then decided to rerun the code, and see if the audit log updates or not (this has been a constant issue in every new instance of running the audit log, it "updates" but adds no record to the table.) This is the first case where a different table is claiming to have updated, but clearly has not. Often with the Auditlog it has been easily solved.
But what's throwing me off is the fact that this record both exists, and doesn't exist. and that using the same exact SQL query, I get different results depending on if it is done via VBA (where it is 'failing?') and SQL which matches the visible records on the table.
Anyone have any suggestions? Or a direction they can point me in?

This Code is stopping halfway through

My below code was all running perfectly fine when I had it all in one function, now that I separated it into a different function for better readability and easier modifications, it's stopping after the function call. Does anyone know why its doing this?
If (Not (Find_First("ERR", Sheets("Consolidated_Data850").Range("G:G")))) Then
Debug.Print "No data errors found!"
Call SaveFile(TempFilePath & "ValidPOs.xls")
' LR = Sheets("Consolidated_Data850").Range("A" & Rows.Count).End(xlUp).row
' Debug.Print "Saving file to... " & Chr(13) & SaveFilePath & "\ValidPOs.xls"
' If Dir(SaveFilePath & "\ValidPOs.xls") <> "" Then Kill SaveFilePath & "\ValidPOs.xls"
' ActiveWorkbook.SaveAs FileName:=SaveFilePath & "\ValidPOs.xls", FileFormat:=51
' Call GenerateEmail(TempFolder & ValidFileName, _
' SaveFilePath & "\ValidPOs.xls", _
' Sheets("Consolidated_Data850").Range("A:F" & LR))
"(" & MarksFolder & ValidTemplate & ") using Range(" & Range("A:F" & LR).Address & ")"
Call GenerateEmail(MarksFolder & ValidTemplate, _
TempFilePath & "ValidPOs.xls", _
Sheets("Consolidated_Data850").Range("A:F" & LR))
Else
Debug.Print "Found errors"
End If
New function that replaced the comment section above...
Private Sub SaveFile(FileNamePath As String)
LR = Sheets("Consolidated_Data850").Range("A" & Rows.Count).End(xlUp).row
Debug.Print "Savingfile to... " & FileNamePath
If Dir(FileNamePath) <> "" Then Kill FileNamePath
On Error GoTo ErrHandler:
Debug.Print "Generating Email (" & TempFilePath & "ValidPOs.xls" & ")" & Chr(13) & _
ActiveWorkbook.SaveAs FileName:=FileNamePath, FileFormat:=51
Exit Sub
ErrHandler:
Debug.Print "Error # " & Str(Err.Number) & " was generated " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
End Sub
Everything works perfectly, but once it leaves that second function (after the save) it stops and does not continue the code
EDIT
It seems as thought the code just stops here, and it's NOT calling the function
Call SaveFile(TempFilePath & "ValidPOs.xls")
Are you sure that TempfilePath is a valid path and that it ends with a "\"?
If you step through with F8 does it highlight the End Sub before stopping or does the yellow highlight vanish from ActiveWorkbook.saveas without moving on?
Check the date and time last saved for your activeworkbook - is it actually being saved? My money is on some error here - out of disk space, invalid path or similar. But if not - and this is pretty random but replace the call - just use
SaveFile TempFilePath & "ValidPOs.xls"
(Note no brackets if you omit the call) - I have had it sometimes work with the shorthand when it's failed on the formal syntax.
Edited in reponse to code changes: You need to Exit Sub before your error handler
Private Sub SaveFile(FileNamePath As String)
LR = Sheets("Consolidated_Data850").Range("A" & Rows.Count).End(xlUp).row
Debug.Print "Savingfile to... " & FileNamePath
If Dir(FileNamePath) <> "" Then Kill FileNamePath
On Error GoTo ErrHandler:
Debug.Print "Generating Email (" & TempFilePath & "ValidPOs.xls" & ")" & Chr(13) & _
ActiveWorkbook.SaveAs FileName:=FileNamePath, FileFormat:=51
EXIT SUB ' if you miss this your error handler below is run irrespective of
' whether there's an error or not.
ErrHandler:
Debug.Print "Error # " & Str(Err.Number) & " was generated " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) &
Err.Description
End Sub
Found the error in the code above... The Range I was using to pass into the GenerateEmail() function was too broad of a range, the LR wasn't being set to a number and was using the entire column instead of a the Last Row that was NOT being calculated
Appreciate everyone for the assistance in error handling and debugging!

How to add an incremental count (version) to a string (file) in Excel/VBA?

I have tried a lot of different things, and it seems like I cannot get it to work. So basically, this is a small piece of my complete code.
I am using Microsoft Scripting Runtime to save the file, using the FileExists() to check if the file actually exist before saving.
This is working fine if I remove the IF-statement/Loop.
However, now it feels like FileExists won´t find the string, MyFilePath, when I run it with the IF/Loop. (getdirsubparentpath is a function)
Dim week, UserName As String
Dim MyFile, MyFilePath As String
Dim version As Integer
' Current week, XX
week = Format(Date, "ww")
' Username, e.g. niclas.madsen
UserName = Environ$("UserName")
' Initials, first letter of last and surname to caps
' e.g. niclas.madsen would be NM
UserName = UCase(Left(UserName, 1) & Mid(UserName, InStr(UserName, ".") + 1, 1))
' fix filename for saving purpose
MyFile = Replace(Replace("SupplierOrganization_W", "", ""), ".", "_") _
& "" _
& week _
& " " _
& UserName _
& ".csv"
'SupplierOrganization_WXX NM
MyFilePath = getDirSubParentPath & MyFile
' Look for the MyFilePath, if it exists then
' Add "-1" after the week number, if 1 exists, add 2, etc.
If Len(Dir(MyFilePath)) <> 0 Then
version = 0
Do
version = version + 1
MyFilePath = Dir(getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version & " " & UserName & ".csv")
Loop Until Len(Dir(MyFilePath)) < 0
End If
Dim tmpFile, tmpFilePath As String
tmpFile = getDirSubParentPath & "tmp_file.txt"
Dim tmpString As String
'Dim fso As New FileSystemObject
Dim fso As Object 'scripting.filesystemobject
Set fso = CreateObject("scripting.filesystemobject")
If fso.FileExists(MyFilePath) = True Then
Application.ScreenUpdating = False
Open MyFilePath For Input As #1
Open tmpFile For Output As #2
tmpString = Input(LOF(1), 1) 'read the entire file
tmpString = Replace(tmpString, (Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34)), "") 'eliminate double quotation and commas in the first line with UTF-8
Print #2, tmpString 'output result
Close #1
Close #2
fso.DeleteFile (MyFilePath) 'delete original file
fso.CopyFile tmpFile, MyFilePath, True 'rename temp file
fso.DeleteFile (tmpFile) 'delete temp file
Application.ScreenUpdating = True
MsgBox "Finished processing file", vbInformation, "Done!"
Else
MsgBox "Cannot locate the file : " & MyFilePath, vbCritical, "Error"
End If
Set fso = Nothing
End Sub
' Get Parent Sub Directory Path
Function getDirSubParentPath()
getDirSubParentPath = ThisWorkbook.Path & Application.PathSeparator & "CSV" & Application.PathSeparator & "Parent" & Application.PathSeparator
End Function
I finally manage to create a solution that seems viable. However, the code could use some cleaning up :) But it gets the job done.
So basically, I am having some issues with the loop. It will return a file named W16-0 (which should actual just be W16). It should only add the "-X" if W16 is found. So the incremental order should be W16, W16-1, W16-2, etc.
What I am doing is that I try to locate if there is a W16-0 and then replace it with W16. Furthermore, it seems like the loop will give me one higher than the amount of files I have. So that is where I also got an error. So if I had a W16-4, it would ask the macro to find and open a file named W16-5, which would obviously not exist.
If somebody could help me clean up the code, I would be really thankful!
Sub RemoveCommasDoubleQ()
'
' Enable a reference to 'Microsft Scripting Runtime'
' under VBA menu option Tools > References
Dim week, UserName As String
Dim MyFile, MyFilePath As String
Dim version As Integer
Dim fso As Object 'scripting.filesystemobject
Set fso = CreateObject("scripting.filesystemobject")
' Current week, XX
week = Format(Date, "ww")
' Username, e.g. niclas.madsen
UserName = Environ$("UserName")
' Initials, first letter of last and surname to caps
' e.g. niclas.madsen would be NM
UserName = UCase(Left(UserName, 1) & Mid(UserName, InStr(UserName, ".") + 1, 1))
' fix filename for saving purpose
MyFile = Replace(Replace("SupplierOrganization_W", "", ""), ".", "_") _
& "" _
& week _
& " " _
& UserName _
& ".csv"
'SupplierOrganization_WXX NM
'MyFilePath = ThisWorkbook.Path & "\CSV\Parent\" & MyFile
MyFilePath = getDirSubParentPath & MyFile
Debug.Print MyFilePath
Debug.Print "BEFORE LOOP"
'version = 1
Do While Len(Dir(MyFilePath)) <> 0
'// If it does, then append a _000 to the name
'// Change _000 to suit your requirement
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version & " " & UserName & ".csv"
'// Increment the counter
version = version + 1
'// and go around again
If MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-0" & " " & UserName & ".csv" Then
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & " " & UserName & ".csv"
Debug.Print MyFilePath
Debug.Print "IF LOOP"
End If
Loop
Debug.Print MyFilePath
Debug.Print "LOOP"
If fso.FileExists(getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version & " " & UserName & ".csv") = False Then
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version - 2 & " " & UserName & ".csv"
MsgBox getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version & " " & UserName & ".csv"
End If
fileName = fso.GetFileName(MyFilePath)
Debug.Print fileName
If MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-0" & " " & UserName & ".csv" Then
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & " " & UserName & ".csv"
Debug.Print MyFilePath
Debug.Print "her it should be 0"
End If
If MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-" & " " & UserName & ".csv" Then
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & "-" & version & " " & UserName & ".csv"
End If
Debug.Print "HER ER VI"
fileName = fso.GetFileName(MyFilePath)
Debug.Print fileName
Dim tmpFile, tmpFilePath As String
tmpFile = getDirSubParentPath & "tmp_file.txt"
Dim tmpString As String
Debug.Print "------"
Debug.Print MyFilePath
If fso.FileExists(getDirSubParentPath & "SupplierOrganization_W" & week & "-0" & " " & UserName & ".csv") = True Then
MsgBox "Found the W-0"
MyFilePath = getDirSubParentPath & "SupplierOrganization_W" & week & " " & UserName & ".csv"
End If
Debug.Print "Found 0?"
Debug.Print MyFilePath
If fso.FileExists(MyFilePath) = True Then
Application.ScreenUpdating = False
Open MyFilePath For Input As #1
Open tmpFile For Output As #2
tmpString = Input(LOF(1), 1) 'read the entire file
tmpString = Replace(tmpString, (Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) _
& Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) _
& Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) & Chr(34) & Chr(44) & Chr(34) _
& Chr(34)), "") 'eliminate double quotation and commas in the first line with UTF-8
Print #2, tmpString 'output result
Close #1
Close #2
fso.DeleteFile (MyFilePath) 'delete original file
fso.CopyFile tmpFile, MyFilePath, True 'rename temp file
fso.DeleteFile (tmpFile) 'delete temp file
Application.ScreenUpdating = True
MsgBox "Finished processing file", vbInformation, "Done!"
Else
MsgBox "Cannot locate the file : " & MyFile, vbCritical, "Error"
End If
Set fso = Nothing
End Sub

SQL command terminates before reaching end of large csv file

I have a large csv file with lots of data that I need to be able to analysis (~6M rows). I want to connect to the file and run SQL command against it to return only the data I'm interested in analysing. The VBA I'm writing is in Excel 2010.
Everything works fine when the number of rows in the csv file is < 4432669. When the csv file has more rows than this, the command seem to terminate at that point in the file and just returns what ever it has found up to that point. No Error is thrown (CN.Errors), I first though it might be that the command timedout but when I increase this it made no difference. I also checked with different csv files just incase that row contained corrupted data, but no luck. Recordset maxrecords is set to 0 (No limit).
I've tried using Microsoft.Jet.OLEDB.4.0; and driver={Microsoft Text Driver (*.txt; *.csv)}; in the connectionstring, both behave the same as described above.
Here is test code I'm using,
Dim CN As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim Err As ADODB.Error
providerstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\cygwin\home\MarkM\csvimport\filtertest4\;" & _
"Extended Properties=" & Chr(34) & "text;HDR=Yes;FMT=Delimited" & Chr(34) & ";"
CN.ConnectionString = providerstr
CN.Mode = adModeRead
CN.CommandTimeout = 900
CN.Open
RS.Open "SELECT exCode FROM 5M_MBP1R04.csv", CN, adOpenStatic, adLockReadOnly
RS.MoveLast
MsgBox "Number of rows = " & RS.RecordCount
For Each Err In CN.Errors
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr & _
" (SQL State: " & Err.SqlState & ")" & vbCr & _
" (NativeError: " & Err.NativeError & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & " No Help file available"
Else
strError = strError & _
" (HelpFile: " & Err.HelpFile & ")" & vbCr & _
" (HelpContext: " & Err.HelpContext & ")" & _
vbCr & vbCr
End If
Debug.Print strError
Next
Really appreciate any help as I'm completely stuck now.
BR's Mark.
Perhaps you are exceeding a memory constraint due to the CursorType. Try changing it to adOpenForwardOnly
Here is the MSDN page describing Cursor Types.
https://msdn.microsoft.com/en-us/library/windows/desktop/ms681771(v=vs.85).aspx

Excel VBA open folder and get GPS info (Exif) of each files in it

Guided by Jzz and David on another post, I discovered a VBA userform and modules that can be imported to Access DB or Excel that will ask you to select a file and it will display the EXIF external info of that file particularly GPS Longitude, Latitude, and Altitude.
My question is how do I convert this so it opens a folder instead and retrieves the GPS info on each of the files in that folder. I know it may need to loop through the contents of a folder but I have no idea how to convert this. Please see attached file and open it as Access DB. I was only able to transfer it to Excel but the code was written in too many extra calls and functions I couldn't understand right away. It would be nice to be able to modify it and make it shorter.
EXIFReader
Sarah
EDIT Thanks to David, here's my modified version:
Sub OpenFromFolder()
On Error GoTo ExifError
Dim strDump As String
'Dim fso As Scripting.FileSystemObject
'Dim fldr As Scripting.Folder
'Dim file As Scripting.file
Set fso = CreateObject("scripting.filesystemobject")
Set fldr = fso.GetFolder("C:/Users/JayP/Downloads/Camera Uploads/Pics") '#### Modify this to your folder location
For Each file In fldr.Files
'## ONLY USE JPG EXTENSION FILES!!
Select Case UCase(Right(file.Name, 3))
Case "JPG"
With GPSExifReader.OpenFile(file.Path)
currrow = Sheet1.UsedRange.Rows.Count + 1
Sheet1.Range("A" & currrow).Value = "GPSLatitudeDecimal: " & .GPSLatitudeDecimal
Sheet1.Range("B" & currrow).Value = "GPSLongitudeDecimal: " & .GPSLongitudeDecimal
Sheet1.Range("C" & currrow).Value = "GPSAltitudeDecimal: " & .GPSAltitudeDecimal
End With
End Select
NextFile:
Next
Exit Sub
ExifError:
MsgBox "An error has occurred with file: " & file.Name & vbCrLf & vbCrLf & Err.Description
Err.Clear
Resume NextFile
End Sub
That is fairly sophisticated code -- written by Wayne Phillips who is a certified Microsoft MVP. While it might be nice to make the code more human-readable, I suspect it is already quite optimized.
I am posting this answer because it's an interesting question/application, normally I would say "Show me what you have tried so far" but given the relative complexity of Wayne's code, I'll waive that requirement. HOWEVER the additional caveat is that I won't answer a dozen follow-up questions on this code to teach you how to use VBA. This code is tested and it works.
There is an unused function call that allows you to open from a path, we are going to use this in a loop, over the files in a specified folder.
Function OpenFile(ByVal FilePath As String) As GPSExifProperties
Set OpenFile = m_ClassFactory.OpenFile(FilePath)
End Function
1. Import the Class Modules from Wayne's code in to your workbook's VBProject (I think you have already done this).
2. Create a new subroutine like the one below, in a normal code module.
Sub OpenFromFolder()
On Error GoTo ExifError
Dim strDump As String
'## REQUIRES REFERENCE TO MICROSOFT SCRIPTING RUNTIME
Dim fso As Scripting.FileSystemObject
Dim fldr As Scripting.Folder
Dim file As Scripting.file
Set fso = CreateObject("scripting.filesystemobject")
Set fldr = fso.GetFolder("C:/users/david_zemens/desktop/") '#### Modify this to your folder location
For Each file In fldr.Files
'## ONLY USE JPG EXTENSION FILES!!
Select Case UCase(Right(file.Name, 3))
Case "JPG"
With GPSExifReader.OpenFile(file.Path)
strDump = strDump & "FilePath: " & .FilePath & vbCrLf
strDump = strDump & "DateTimeOriginal: " & .DateTimeOriginal & vbCrLf
strDump = strDump & "GPSVersionID: " & .GPSVersionID & vbCrLf
strDump = strDump & "GPSLatitudeDecimal: " & .GPSLatitudeDecimal & vbCrLf
strDump = strDump & "GPSLongitudeDecimal: " & .GPSLongitudeDecimal & vbCrLf
strDump = strDump & "GPSAltitudeDecimal: " & .GPSAltitudeDecimal & vbCrLf
strDump = strDump & "GPSSatellites: " & .GPSSatellites & vbCrLf
strDump = strDump & "GPSStatus: " & .GPSStatus & vbCrLf
strDump = strDump & "GPSMeasureMode: " & .GPSMeasureMode & vbCrLf
strDump = strDump & "GPSDOPDecimal: " & .GPSDOPDecimal & vbCrLf
strDump = strDump & "GPSSpeedRef: " & .GPSSpeedRef & vbCrLf
strDump = strDump & "GPSSpeedDecimal: " & .GPSSpeedDecimal & vbCrLf
strDump = strDump & "GPSTrackRef: " & .GPSTrackRef & vbCrLf
strDump = strDump & "GPSTrackDecimal: " & .GPSTrackDecimal & vbCrLf
strDump = strDump & "GPSImgDirectionRef: " & .GPSImgDirectionRef & vbCrLf
strDump = strDump & "GPSImgDirectionDecimal: " & .GPSImgDirectionDecimal & vbCrLf
strDump = strDump & "GPSMapDatum: " & .GPSMapDatum & vbCrLf
strDump = strDump & "GPSDestLatitudeDecimal: " & .GPSDestLatitudeDecimal & vbCrLf
strDump = strDump & "GPSDestLongitudeDecimal: " & .GPSDestLongitudeDecimal & vbCrLf
strDump = strDump & "GPSDestBearingRef: " & .GPSDestBearingRef & vbCrLf
strDump = strDump & "GPSDestBearingDecimal: " & .GPSDestBearingDecimal & vbCrLf
strDump = strDump & "GPSDestDistanceRef: " & .GPSDestDistanceRef & vbCrLf
strDump = strDump & "GPSDestDistanceDecimal: " & .GPSDestDistanceDecimal & vbCrLf
strDump = strDump & "GPSProcessingMethod: " & .GPSProcessingMethod & vbCrLf
strDump = strDump & "GPSAreaInformation: " & .GPSAreaInformation & vbCrLf
strDump = strDump & "GPSDateStamp: " & .GPSDateStamp & vbCrLf
strDump = strDump & "GPSTimeStamp: " & .GPSTimeStamp & vbCrLf
strDump = strDump & "GPSDifferentialCorrection: " & .GPSDifferentialCorrection & vbCrLf
Debug.Print strDump '## Modify this to print the results wherever you want them...
End With
End Select
NextFile:
Next
Exit Sub
ExifError:
MsgBox "An error has occurred with file: " & file.Name & vbCrLf & vbCrLf & Err.Description
Err.Clear
Resume NextFile
End Sub
You need to modify this:
Set fldr = fso.GetFolder("C:/users/david_zemens/desktop/")
And also this. I assume you already know how to put the data in a worksheet or display it on a form, etc. This line only prints to the console in the Immediate window of the VBA, it will not write to a worksheet/etc. unless you modify it to do so. That is not part of the question, so I will leave that up to you to work out :)
Debug.Print strDump
NOTE: I removed some object variables that you won't have in Excel, and added some new variables to do the Folder/Files iteration. I put in simple error handling to inform you of errors (msgbox) and resume the next file. In my testing, the only error I got was some files do not have EXIF data.