Option Explicit

Public Sub GetFileNames()

'This script can be used to get file names and properties into an Excel

'spreadsheet. To use, copy and paste the script into a new module in Excel.

'Then reference the Microsoft Scripting Runtime library. Compile and test

'it out.

'By C. Eric Cashon

Dim Directories As New Scripting.FileSystemObject

Dim CDirectory As Scripting.Folder

Dim CFiles As Scripting.Files

Dim CFile As Scripting.File

Dim varFile As Variant

Dim MultiSelect As Boolean

Dim lngNumberOfFilesSelected As Long

Dim strPath As String

Dim lngFileNameLength As Long

Dim strFileName As String

Dim strBuilder As String

Dim strName As String

Dim strChar As String

Dim strSheetName As String

Dim strDate As String

Dim strDate2 As String

Dim lngDateLength As Long

Dim lngCurRow As Long

Dim lngBackwards As Long

Dim blnSwitch As Boolean

Dim i As Long

Dim j As Long

varFile = Application.GetOpenFilename(, , , , MultiSelect = False)

If IsArray(varFile) = False Then

If varFile = False Then

MsgBox "You didn't select any files."

Exit Sub

End If

End If

strPath = varFile(1)

lngFileNameLength = Len(strPath)

For i = 1 To lngFileNameLength

lngBackwards = lngFileNameLength + 1 - i

strChar = Mid(strPath, lngBackwards, 1)

If strChar = "\" And blnSwitch = False Then

strBuilder = ""

blnSwitch = True

Else

strBuilder = strChar & strBuilder

End If

Next

strChar = ""

'Can't use a \ in a spreedsheet name.

strDate = Date

strDate2 = ""

lngDateLength = Len(strDate)

For i = 1 To lngDateLength

strChar = Mid(strDate, i, 1)

If strChar = "/" Then

strChar = "-"

End If

strDate2 = strDate2 & strChar

Next

strChar = ""

'Create a new spreedsheet in the current workbook.

strSheetName = "FileNames " & strDate2

Sheets.Add Type:=xlWorkbook, Count:=1, before:=Sheets(1)

Sheets(1).Select

Sheets(1).Name = strSheetName

'Set a file scripting object to use so that you can

'get some file properties.

Set CDirectory = Directories.GetFolder(strBuilder)

Set CFiles = CDirectory.Files

strBuilder = ""

lngNumberOfFilesSelected = UBound(varFile)

lngCurRow = 1

For i = 1 To lngNumberOfFilesSelected

strFileName = varFile(i)

lngFileNameLength = Len(strFileName)

For j = 1 To lngFileNameLength

strChar = Mid(strFileName, j, 1)

If strChar = "\" Then

strBuilder = ""

Else

strBuilder = strBuilder & strChar

End If

Next

Range(Cells(lngCurRow, 1), Cells(lngCurRow, 1)).Value = strFileName

Range(Cells(lngCurRow, 2), Cells(lngCurRow, 2)).Value = strBuilder

For Each CFile In CFiles

strName = CFile.Name

If strName = strBuilder Then

Range(Cells(lngCurRow, 3), Cells(lngCurRow, 3)).Value = CFile.Size

Range(Cells(lngCurRow, 4), Cells(lngCurRow, 4)).Value = CFile.DateCreated

Range(Cells(lngCurRow, 5), Cells(lngCurRow, 5)).Value = CFile.DateLastModified

Range(Cells(lngCurRow, 6), Cells(lngCurRow, 6)).Value = Now()

Exit For

End If

Next

lngCurRow = lngCurRow + 1

Next

Set CDirectory = Nothing

Set CFiles = Nothing

End Sub

Public Sub SaveToAccess()

'This script will save the imported file data in the Excel spreadsheet into

'an Access database. It is set up to save to a database at C:\TestData.mdb

'With a table name of TestTable. TestTable has six fields in the following order.

'Path Text (256), FileName Text, Bytes Number Long Integer, DateCreated Date/Time,

'DateModified Date/Time, CurrentDate Date/Time. It is easy to change things for

'saving into other databases or table names. Also remember to have a reference to

'the Microsoft ActiveX Data Objects 2.x Library before running the script.

'By C. Eric Cashon

Dim cnn As ADODB.Connection

Dim cmd As ADODB.Command

Dim strConnect As String

Dim strSQL As String

Dim strSQLserver As String

Dim strBuilder As String

Dim lngRows As Long

Dim lngColumnCounter As Long

Dim cell As Range

Dim strMsg As String

Dim i As Long

On Error GoTo CheckError

lngRows = ActiveSheet.UsedRange.Count / 6

strSQL = ""

strBuilder = """"

lngColumnCounter = 1

strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" _

& "Data Source=C:\TestDatabase.mdb;"

Set cnn = New ADODB.Connection

cnn.Open strConnect

Set cmd = New ADODB.Command

For i = 1 To lngRows

Range(Cells(i, 1), Cells(i, 6)).Select

For Each cell In Selection

If lngColumnCounter <> 6 Then

strBuilder = strBuilder & cell.Value & """" & ", " & """"

lngColumnCounter = lngColumnCounter + 1

Else

strBuilder = strBuilder & cell.Value & """"

End If

Next

strSQL = "INSERT INTO TestTable VALUES(" & strBuilder & ")"

With cmd

.ActiveConnection = cnn

.CommandText = strSQL

.CommandType = adCmdText

.Execute

End With

strBuilder = """"

strSQL = ""

lngColumnCounter = 1

Next

cnn.Close

Exit Sub

CheckError:

If Err.Number = -2147467259 Then

MsgBox " A connection to the database can't be made! Look" & vbCrLf _

& " at the VBA code to change connection parameters and" & vbCrLf _

& " make sure that the TestTable is closed."

Else

strMsg = "Error number " & str(Err.Number) & " occured: " & Err.Description

MsgBox strMsg, vbCritical

End If

End Sub