I need to find from an Access DB if any file in a folder got changed. For this reason I created a table containing the file information (name and DateLastModified). However there is the problem, that Windows always adjusts the DateLastModified to the local time zone and this value will even change on daylight savings (means: DateLastModified will change when DST activates/deactivates)!
To overcome this and to find the files true 'DateLastModified'-date I use FileSystemObject to get 'DateLastModified' and convert the returned value to UTC by means of Function GetUTC. Then I store this value in the database. I carefully tested GetUTC - it will return a value not depending on DST (tested for time zones CET and CEST).
Re-querying the folder and comparing a newly calculated 'DateLastModified' against the stored 'DateLastModified' will fail for approximately 15%-35% of the files - is seems random which files fail! Could it be that DT.GetVarDate(False) in GetUTC does not always return the same binary value?
However using debug.print always shows the same Date & Time for the failing files and the value stored in the database! MS specs says the resolution of datatype 'Date' is one second. So I do not understand how 2 Dates that show the same value will result to false when compared! Sample output of a failed file:
1477 493 18.12.2013 19:03:26 18.12.2013 19:03:26 scanColor0010.pdf
How can I make this work?
Option Compare Database
Option Explicit
Public ws As Workspace
Public db As Database
Function GetUTC(dLocalTimeDate As Date) As Date
Dim DT As Object
Dim curTime As Date
curTime = Now()
Set DT = CreateObject("WbemScripting.SWbemDateTime")
DT.SetVarDate curTime
GetUTC = dLocalTimeDate - curTime + DT.GetVarDate(False)
End Function
'------------------------------------------------------------
' Test_UTC_Click
'
'------------------------------------------------------------
Private Sub Test_UTC_Click()
Dim colFiles As New Collection
Dim vFile As Variant
Dim rst As Recordset
Dim fso As FileSystemObject
Dim f As File
Dim lngCountWrong As Long
Dim lngCount As Long
Set ws = DBEngine.Workspaces(0)
Set db = CurrentDb()
RecursiveDir colFiles, "Y:\", "*.pdf", False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each vFile In colFiles
Set f = fso.GetFile(vFile)
Set rst = db.OpenRecordset("SELECT tblFiles.*, tblFiles.fileName FROM tblFiles WHERE (((tblFiles.fileName)=""" & f.Name & """));")
rst.MoveFirst
lngCount = lngCount + 1
If (rst!fileDateModified = GetUTC(f.DateLastModified)) Then
'Ok, this is always expected
Else
'Uuuups - what went wrong?
lngCountWrong = lngCountWrong + 1
Debug.Print lngCount, lngCountWrong, rst!fileDateModified, GetUTC(f.DateLastModified), f.Name
End If
rst.Close
Set f = Nothing
DoEvents
Next vFile
Debug.Print "finished", lngCount
Set fso = Nothing
End Sub
'------------------------------------------------------------
' CreateTestdata_Click
'
'------------------------------------------------------------
Private Sub CreateTestdata_Click()
Dim colFiles As New Collection
Dim vFile As Variant
Dim rst As Recordset
Dim fso As FileSystemObject
Dim f As File
Set ws = DBEngine.Workspaces(0)
Set db = CurrentDb()
db.Execute "DELETE tblFiles.* FROM tblFiles;"
Set rst = db.OpenRecordset("SELECT tblFiles.* FROM tblFiles;")
RecursiveDir colFiles, "Y:\", "*.pdf", False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each vFile In colFiles
Set f = fso.GetFile(vFile)
rst.AddNew
rst!filename = f.Name
Debug.Print f.Name
rst!fileDateModified = GetUTC(f.DateLastModified)
rst.Update
Set f = Nothing
DoEvents
Next vFile
Set fso = Nothing
rst.Close
Debug.Print "Finished creating"
MsgBox "Finished creating"
End Sub
Rewrite
If (rst!fileDateModified = GetUTC(f.DateLastModified)) Then
'Ok, this is always expected
Else
to
If Datediff("s",rst!fileDateModified,GetUTC(f.DateLastModified)) = 0 Then
'Ok, this is always expected
Else
Further reading on Datediff
Further reading on How to store, calculate, and compare Date/Time data in Microsoft Access. Although this article is on Access it should be similar in Excel
Related
I am using the below code to reference a table that has full path information to move (or copy) files from 1 location to another. However, it's not moving anything, but is completing per my Debug.Print message (Move Complete 2/22/2021 1:22:41 PM). Any thoughts on what I'm missing?
Additionally, I'd like to build the folder/subfolder structure where the file was located in the source...but don't know how to achieve that...and pointers on how to do this?
Sub copy_files_from_table()
Dim FSO As Object
Dim source As String
Dim destination As String
Dim SQL As String
Dim RS As DAO.Recordset
Dim db As DAO.Database
SQL = "select * from file_test"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set RS = db.OpenRecordset(SQL)
source = RS!LocalFile
destination = "C:\Temp\Test"
While Not RS.EOF
If Dir(source, vbDirectory) <> "" Then
objFSO.CopyFolder source, destination:=destination '
Debug.Print "Move Folder Command Complete From: " & destination
Else
End If
RS.MoveNext
Wend
Debug.Print "Move Complete " & Now()
End Sub
Appreciate any help provided.
So far, I have gotten the following code to work on file paths <259; however, anything longer is causing the code to error. Since I'm pretty green on coding:) any suggestions how I can get around the long file path names?
Sub CopyFilesFromTable2()
On Error GoTo ErrorHandler
Dim source As String
Dim destination As String
Dim FSO As New FileSystemObject
Dim SQL As String
Dim RS As DAO.Recordset
Dim db As DAO.Database
'Test Table
SQL = "select * from file_test"
'Prod Table
'SQL = "select * from file"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set RS = db.OpenRecordset(SQL)
source = RS!LocalFile
File = VBA.FileSystem.Dir(source)
destination = "D:\Temp\Test\"
With RS
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
FSO.CopyFile RS!LocalFile, destination
.MoveNext
Wend
End If
.Close
End With
ExitSub:
Set RS = Nothing
'set to nothing
MsgBox "Done!"
Exit Sub
ErrorHandler:
MsgBox Err, vbCritical
Resume ExitSub
End Sub
I'm trying to iterate through the records of a database, in order to save all of the attachments associated to certain fields of each record. I managed to find a way to properly export the attachments by cycling though the entire table. However, it would be way more useful to export only the attachments of the records previously selected by the user in the table form.
This is what my code structure looks like at the moment:
Public Function Main()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim CRT As DAO.Field2
Dim cat As DAO.Field2
Dim prg As DAO.Field2
Dim strFullPath As String
Dim CatPrg As String
Dim fso As New FileSystemObject
'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Archieve_Table")
Set STF = rst("STF")
Set cat = rst("CAT")
Set prg = rst("PRG")
'Navigate through the table
Do While Not rst.EOF
CatPrg = cat.Value & "-" & prg.Value
'Get the recordset for the Attachments field STF
Set rsA = STF.Value
'Save all attachments in the field
Do While Not rsA.EOF
strPath = CurrentProject.Path & "\Export\" & CatPrg & "\STF\"
strFullPath = strPath & rsA("FileName")
'Make sure the file does not exist and save
If Dir(strFullPath) = "" Then
rsA("FileData").SaveToFile strFullPath
End If
'Next attachment
rsA.MoveNext
Loop
rsA.Close
'Next record
rst.MoveNext
Loop
rst.Close
dbs.Close
Set STF = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing
Set cat = Nothing
Set prg = Nothing
End Function
Probably I need to add some conditions at Set rst = dbs.OpenRecordset("Archieve_Table") when I set the OpenRecordset.
Hoping someone could help:)
I have an MS Access table that holds file names along with other data Example:
AcctNum, FileName
12345, abc123.pdf
I have written a SQL to sort the file name based on account number. Example: Select * from tblTest where AcctNum='12345'
Files with these file names are located in a directory (C:\Test\<filename>.pdf)
I need to move the selected files based on the SQL I've written to move those files to a different directory (D:\Test\FromCode). Filename 'abc123.pdf' is located in C:\Test move to D:\test, loop through SQL results to move files based on criteria.
Attached is some VBA that I have written that I can get a file to copy from source to destination manually when I input the exact filename (as seen in the code, the file name is "abc123"), but I want to tie it to the mysql query recordset and move the group which will contain 1000's of files. Anyone know the best way I can tie this to recordset?
Appreciate any direction/help you provide.
Sub UpdateDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim mysource As String
Dim mydes As String
Dim mysql As String
mysql = "SELECT * from tblTest where ACCTNUM = 123456"
mysource = "C:\Test"
mydes = "D:\Test\FromCode\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(mysource)
Set db = CurrentDb
Set rs = db.OpenRecordSet(mysql)
'I want to tie mysql recordset to below to move all files/records based
'on ACCTNUM. This could result in moving 1000's of files to
'destination.
For Each objFile In objFolder.Files
If InStr(1, objFile.Name, "abc123") > 0 Then
Debug.Print "yes"
objFSO.CopyFile objFile, mydes
Else
Debug.Print "no"
End If
Next
'clean
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Here is your code with a working answer: To be sure, #June7 is correct, but putting the answer in your context:
Sub UpdateDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim mysource As String
Dim mydes As String
Dim mysql As String
mysql = "SELECT * from tblTest where ACCTNUM = 123456"
mysource = "C:\Test" 'Missing backslash - added later
mydes = "D:\Test\FromCode\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(mysource)
Set db = CurrentDb
Set rs = db.OpenRecordSet(mysql)
'I want to tie mysql recordset to below to move all files/records based
'on ACCTNUM. This could result in moving 1000's of files to
'destination.
While Not rs.EOF
sourceFile = mysource & "\" & rs!Filename 'Added a missing backslash
destFile = mydes & rs!Filename
If Dir(sourceFile) <> "" Then 'If sourceFile exists, then Dir(sourceFile) will return it's name, otherwise empty string
FileCopy sourceFile, destFile
End If
rs.MoveNext
Wend
End Sub
That SQL is not sorting records, it is filtering.
The recordset serves no purpose if you do not loop through records. If you do not want to simply copy all files and the complete account number is not part of filename, then need to loop through recordset, not folder. Use filename from field in the file copy. FSO is not needed - Access FileCopy method can serve.
...
mysource = "C:\Test\"
...
Do While Not rs.EOF
If Dir(mysource & rs!Filename) <> "" Then FileCopy mysource & rs!Filename, mydes & rs!Filename
Loop
I'm sure there is a really easy way around this. Say I have a query called query_1 and upon running this query the user has to input the two values which are labelled as q_month, q_year.
I am running a bit of code that exports this query, but I want to take the user input values as strings which I can then use further down the line in my code. How would one do this?
(Apologies I am new to syntax in Access)
See below my attempt (I open the query first as it then will prompt user to input value). I know the lines v_Month and v_year are incorrect but hopefully it shows what I want to do clearer.
Thanks!
Function ExportExcel()
Dim myQueryName As String, sFolderPath As String, v_Month As String, v_Year As String
myQueryName = "query_1"
sFolderPath = "C:\Folder1"
DoCmd.OpenQuery myQueryName
v_Month = [query_1].[q_month]
v_Year = [query_1].[q_year]
myExportFileNameExcel = sFolderPath & "\" & v_Month & "\Test.xlsx"
DoCmd.OutputTo acOutputQuery, myQueryName, "ExcelWorkbook(*.xlsx)", myExportFileNameExcel, False, "", , acExportQualityPrint
End Function
You can use InputBox:
SomeStringVariable = InputBox("Please enter value:")
To set the parameters before running the query, use DoCmd.SetParameter:
DoCmd.SetParameter method (Access)
You haven't given the SQL for the query so I wrote a basic query showing how to use parameters:
PARAMETERS q_month Long, q_year Long;
SELECT *
FROM Table1
WHERE YEAR(DateField) = q_year AND MONTH(DateField) = q_month
You can then use this code to export the query data to Excel:
Sub Test()
Dim MonthNumber As Long, YearNumber As Long
'Get the details from the user.
MonthNumber = InputBox("Enter month number:")
YearNumber = InputBox("Enter full year:")
'Pass the details to the Export procedure.
ExportToExcel MonthNumber, YearNumber
End Sub
Public Function ExportToExcel(lMonth As Long, lYear As Long)
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim oXL As Object, oWB As Object, oWS As Object
'Open the query as a recordset.
Set qdf = CurrentDb.QueryDefs("Query1")
With qdf
.Parameters("q_Month") = lMonth
.Parameters("q_Year") = lYear
Set rst = .OpenRecordset
End With
Set oXL = CreateXL 'Create an instance of Excel.
Set oWB = oXL.WorkBooks.Add 'Create workbook.
Set oWS = oWB.Worksheets(1) 'Reference to first sheet.
'Copy the data over to row 2.
oWS.Range("A2").CopyFromRecordset rst
'Add the field headings to row 1
For Each fld In rst.Fields
oWS.cells(1, fld.OrdinalPosition + 1) = fld.Name
Next fld
'Using the passed values again.
MsgBox "Data exported for " & Format(DateSerial(lYear, lMonth, 1), "mmmm 'yy")
'Assumes the month folder already exists.
'Names folders as "01_January_18" to "12_December_18"
oWB.SaveAs "C:\Folder1\" & Format(DateSerial(lYear, lMonth, 1), "mm_mmmm_yy") & "\Test.xlsx", 51
rst.Close
qdf.Close
Set rst = Nothing
Set qdf = Nothing
End Function
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
End Function
I´m creating a macro that crawls into subfolders and retrieve the name of some files. I used code from this answer to another question and works fine to get the results into the immediate window, but I want to get them into cells, as a list. What I get is just the result of the first iteration.
What I´m trying to do might be obvious, but I swear I tried and couldn´t find the answer by myself. For the record, I´m just starting to code.
My code here. The important part comes at the end, in Sub ListFiles(fld As Object, Mask As String).
Option Explicit
Sub Retrieve_Info()
Dim strPath As Variant
Dim pasta_destino As Range
Dim fle As String
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Set pasta_destino = ThisWorkbook.Worksheets("VINCULATOR").Range("pasta_destino")
strPath = Application.GetOpenFilename _
(Title:="Selecione o arquivo.xlsx", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If Not strPath = False Then
pasta_destino = strPath
fle = Dir(strPath)
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder(Replace(strPath, fle, ""))
Mask = "*.xlsx"
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
Next
End If
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim fl As Object 'File
Dim vrow As Integer
Dim vinculadas As Range
Dim n_vinc As Range
Set vinculadas = ThisWorkbook.Worksheets("VINCULATOR").Range("vinculadas")
Set n_vinc = ThisWorkbook.Worksheets("VINCULATOR").Range("n_vinc")
vrow = 0
For Each fl In fld.Files
If fl.Name Like Mask And InStr(fl.Name, "completo") = 0 Then
vrow = vrow + 1
vinculadas.Cells(vrow, 1) = fld.Path & "\" & fl.Name
End If
Next
n_vinc = vrow
End Sub
Please, help!
I have taken a slightly different approach which might be easier for you to follow in addition to executing faster. Please try this.
Sub SpecifyFolder()
' 10 Dec 2017
Dim Fd As FileDialog
Dim PathName As String
Dim Fso As Object
Dim Fold As Object, SubFold As Object
Dim i As Long
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.ButtonName = "Select"
.InitialView = msoFileDialogViewList
.InitialFileName = "C:\My Documents\" ' set as required
.Show
If .SelectedItems.Count Then
PathName = .SelectedItems(1)
Else
Exit Sub ' user cancelled
End If
End With
Set Fd = Nothing
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fold = Fso.GetFolder(PathName)
ListFiles Fold, "*.xlsx"
For Each SubFold In Fold.SubFolders
ListFiles SubFold, "*.xlsx"
Next SubFold
Set Fso = Nothing
End Sub
Sub ListFiles(Fold As Object, _
Mask As String)
' 10 Dec 2017
Dim Fun() As String ' file list
Dim Rng As Range
Dim Fn As String ' file name
Dim i As Long ' array index
ReDim Fun(1 To 1000) ' maximum number of expected files in one folder
Fn = Dir(Fold.Path & "\")
Do While Len(Fn)
If Fn Like Mask And InStr(Fn, "completo") = 0 Then
i = i + 1
Fun(i) = Fold.Path & "\" & Fn
End If
Fn = Dir
Loop
If i Then
ReDim Preserve Fun(1 To i)
With ThisWorkbook.Worksheets("VINCULATOR")
' specify the column in which to write (here "C")
i = .Cells(.Rows.Count, "C").End(xlUp).Row
Set Rng = .Cells(i + 1, "C").Resize(UBound(Fun), 1)
Application.ScreenUpdating = False
Rng.Value = Application.Transpose(Fun)
Application.ScreenUpdating = True
End With
End If
End Sub
As you see, I have dispensed with specifying a target range, just the sheet and the column (I chose column C; please change as required in the ListFiles sub). Note that the code appends new lists to the existing content of the indicated column.
There are two things the code doesn't do to my entire satisfaction. One, it doesn't write to the first row of an empty column C. Instead, it leaves the first row blank. You might actually like that. Two, It doesn't do sub-subfolders. File names are extracted only from the selected folder and its immediate subfolders. Additional programming would be required for either additional feature, if required.
Finally, I admit that I didn't test for correct transfer of the lists to the worksheet. I think it works correctly but you should check that the first and last names are listed in your worksheet column. They are extracted from the folder but perhaps their omission when writing to the sheet would be a typical error to occur in this particular method.