I have an import specification for csv files which, when I run it on a file through the GUI, works just fine. However, when I run it through VBA, for some reason it forgets that one column is supposed to be a Text column and makes it a Number column instead, thereby causing tons of errors.
My code is below. It works in the sense that everything runs properly, but for some reason the import specification for the CSVs does not run properly. The meaningless case switch is a place holder, as I will need to add more types of reports after I get the first working.
Sub ImportDE(Folder As Object)
Dim db As DAO.Database
Dim names As DAO.Recordset
Dim Files As Object, file As Object, SubFolders As Object, subfolder As Object
Dim ExString As Variant
Dim check As Boolean
Dim FileChange As String
Set db = CurrentDb
On Error Resume Next: db.TableDefs.Delete "tblImport": On Error GoTo 0
db.TableDefs.Refresh
Set names = CurrentDb.OpenRecordset("SELECT Old FROM DENames")
Set Files = Folder.Files
Set SubFolders = Folder.SubFolders
For Each subfolder In SubFolders
ImportDE subfolder
Next
With names
Do While Not .EOF
ExString = .Fields(0)
For Each file In Files
If InStr(file.Type, "Worksheet") > 0 Then
If InStr(file.Path, ExString & ".xls") > 0 Then
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=acSpreadsheetTypeExcel9, _
TableName:="tblImport_" & ExString, _
filename:=file.Path, _
HasFieldNames:=True, _
Range:="A:CT"
db.TableDefs.Refresh
End If
ElseIf InStr(file.Type, "Comma Separated") > 0 Then
If InStr(file.Path, ExString & ".csv") > 0 Then
Select Case ExString
Case "Usage"
DoCmd.TransferText _
TransferType:=acImportDelim, _
SpecificationName:=UsageCSV, _
TableName:="tblImport_" & ExString, _
filename:=file.Path, _
HasFieldNames:=True
db.TableDefs.Refresh
End Select
End If
End If
Next
.MoveNext
Loop
End With
db.Close: Set db = Nothing
End Sub
Am I missing something obvious? Why doesn't the import spec work properly?
The TransferText SpecificationName parameter is supposed to be a string expression. Since the code does not declare a variable named UsageCSV, I'm guessing that is the literal name of the specification. If that's correct, enclose the name in double quotes.
DoCmd.TransferText _
TransferType:=acImportDelim, _
SpecificationName:="UsageCSV", _
TableName:="tblImport_" & ExString, _
filename:=file.Path, _
HasFieldNames:=True
At the top of your code module After Option Compare Database
Add Option Explicit.
This will require all of your variable to be declared and you will never have this issue again
Related
I have an MS Access 2010 Database that has a table that is linked to a CSV file. Upating the CSV files location using the inbuilt Access "Linked Table Manager" doesn't work.
I check the file i want to update, choose "always prompt for new location" and select the new file. I get a message telling me that the update was successful, but when I go to check, the table is still linked to the old file.
Is this a MS Access bug and if so what is the most efficient workaround?
I ended up deleting the old table and manually recreating a new table with the same specifications.
*Updated: -- I forgot to include the referenced Function Relink_CSV :(
Yes, I would call it a bug. Microsoft probably calls it a 'design characteristic'.
As you have discovered, you can manually fix the issue. If you are interested in a code solution, then I may have something that will work for you -- if your CSV file is delimited by comma's.
The following code (which you need to modify!) will delete the existing linked csv file, then add a link to the same file. For debugging, my code then deletes that link and adds a link to a different file name, but in the same folder.
There are other solutions that make use of a saved Import Specification, that you can reuse, if your csv format is not simple.
Option Explicit
Option Compare Database
Sub Call_Relink()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim strTableName As String
Dim strPath As String
Dim strFile As String
Dim iReply As Integer
iReply = MsgBox("WARNING!!!! This code will remove the linked tables 'FileA' and 'FileB'" & vbCrLf & vbCrLf & _
"Click 'Yes' to Continue" & vbCrLf & "Click 'No' to Stop", vbYesNo, "CAUTION!! Will remove linked table(s)")
If iReply <> vbYes Then
Exit Sub
End If
On Error GoTo Error_Trap
Set dbs = CurrentDb
dbs.TableDefs.Delete "FileA" ' For testing; delete table if it already exists
strPath = "C:\Temp\"
strFile = "FileA.csv"
strTableName = "FileA" ' Table name in Access
Relink_CSV strTableName, strPath, strFile ' Call function to link the CSV file
dbs.TableDefs.Refresh ' Refresh TDF's
Debug.Print "Pause here and check file link" ' Put a breakpoint here; pause and look at the table in Access
dbs.TableDefs.Delete "FileA" ' For testing; delete table if it already exists
strPath = "C:\Temp\" ' Path to next csv
strFile = "FileB.csv" ' Name of next csv file
strTableName = "FileA" ' Table name in Access
Relink_CSV strTableName, strPath, strFile ' Call function to link to a different CSV file
dbs.TableDefs.Refresh
Debug.Print "Pause here and check file link" ' Put a breakpoint here; pause and look at the table in Access
My_Exit:
Set dbs = Nothing
Exit Sub
Error_Trap:
Debug.Print Err.Number & vbTab & Err.Description
If Err.Number = 3265 Then ' Item not found in this collection.
' Ignore this error
Resume Next
End If
MsgBox Err.Number & vbTab & Err.Description
Resume My_Exit
Resume
End Sub
Function Relink_CSV(strTableName As String, strPath As String, strFile As String)
' (1) Name of the table in Access
' (2) Path to the file
' (3) File name
On Error GoTo Relink_Err
DoCmd.TransferText acLinkDelim, , strTableName, strPath & strFile, False, ""
Relink_Exit:
Exit Function
Relink_Err:
Debug.Print Err.Number & vbTab & Err.Description
MsgBox Err.Number & vbTab & Err.Description
Resume Relink_Exit
Resume
End Function
I am attempting to import data into my MS Access project via TransferText, but am receiving error #3051: "The Microsoft Access database engine cannot open or write to the file ''. It is already opened exclusively by another user, or you need permissions to view and write its data."
It is odd to me that the filename given in the error message is blank. I have checked and rechecked the file name, even to perform a check "If Not fso.FileExists(file_name) Then ... End If" prior to the TransferText call.
I have also checked and rechecked the table name and the file permissions. The table is successfully emptied before the TransferText call, so I know that works. The file is in a subfolder relative to the Access database file in a folder on my desktop. I have not set or unset any permissions for any of the folders or files.
Until now I had been using DoCmd.TransferSpreadsheet to import the data that is downloaded from a web based tool, but I found Excel was misinterpreting some alphanumeric codes as numbers in scientific format, such as 1E100 would become 1E+100 in the Excel file, so the data was corrupted before getting to the Access database. These codes are getting corrupted in uncorrectable ways, so I can't modify the data after import. I found I could save the data from the web tool as a CSV file rather than an Excel file; this led me to try to use DoCmd.TransferText.
Below is the code I am using:
Private Function ImportExcel( _
ByVal file_name As String, _
ByVal table_name As String _
) As Integer
On Error GoTo Error
Dim fso As FileSystemObject, folder_name As String
Dim xl_book As Excel.Workbook
Dim xl_sheet As Excel.Worksheet
Dim i As Integer
' suppress excel's file-not-found popup
Set fso = New FileSystemObject
If Not fso.FileExists(file_name) Then
ImportExcel = -1
GoTo Finish
End If
' gets a workbook from a global application object
Set xl_book = Util.GetExcelWorkbook( _
file_name:=file_name, _
visible:=False, _
use_cache:=True _
)
If xl_book Is Nothing Then
ImportExcel = -1
GoTo Finish
End If
' always use the first worksheet
Set xl_sheet = xl_book.Sheets(1)
' fake the first record to force columns types
xl_sheet.range("A2").EntireRow.Insert
For i = 1 To xl_sheet.UsedRange.columns.count
xl_sheet.Cells(2, i) = "test"
Next i
' make sure the table is closed
DoCmd.Close _
ObjectType:=acTable, _
ObjectName:=table_name, _
Save:=acSaveNo
' link to file
DoCmd.SetWarnings False
If ".csv" = Right(file_name, 4) Then
' empty table
DoCmd.RunSQL "DELETE * FROM " & table_name, True
' import data
Debug.Print table_name
Debug.Print file_name
DoCmd.TransferText _
TransferType:=acImportDelim, _
SpecificationName:=table_name & " Import Spec", _
TableName:=table_name, _
FileName:=file_name, _
HasFieldNames:=True
Else
' delete table
On Error Resume Next
DoCmd.DeleteObject _
ObjectType:=acTable, _
ObjectName:=table_name
If 0 <> Err.Number Then
Resume Next
End If
On Error GoTo Error
' import data
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
TableName:=table_name, _
FileName:=file_name, _
HasFieldNames:=True, _
range:=xl_sheet.NAME() & "!" & _
xl_sheet.range( _
xl_sheet.Cells(1, 1), _
xl_sheet.Cells( _
xl_sheet.UsedRange.rows.count, _
xl_sheet.UsedRange.columns.count _
) _
).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
SpreadsheetType:=acSpreadsheetTypeExcel9
End If
DoCmd.SetWarnings True
Finish:
Set xl_sheet = Nothing
If Not xl_book Is Nothing Then
xl_book.Close SaveChanges:=False
End If
Set xl_book = Nothing
Set fso = Nothing
Exit Function
Error:
Resume Finish
End Function
The two Debug.Print calls just prior to the DoCmd.TransferText call print exactly what is expected.
I know this question has been asked over and over, but I can't follow any of the guides I've found.
I'm a total beginner with Access and writing VBA, so I found some code that will help me import A LOT of files into separate tables in Access.
I have tried several variations of putting the code in and calling from a macro or a button...none of them have been successful.
There might be something wrong with the code, but I don't know enough to figure it out. I'm also pretty sure I'm doing something else wrong when trying to call the function. Please help me!
Here's the code:
Option Compare Database
Option Explicit
Function DoImport()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Documents and Settings\user\Desktop\folder"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
strTable = Left(strFile, Len(strFile) - 4)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
strFile = Dir()
Loop
End Function
To call this procedure it either needs to exist in the current form where the button is or reside in a Module of its own.
Because the function does not return a value or have any arguments to call it you would type the following VBA code in a button's On Click event:
DoImport
If you wish to make sure the code is actually running you can set a breakpoint by pressing F9 on an executable line of code
Or type the word Stop where you want to debug
The code itself will not be very useful until you have made the changes to the literal strings as the code comments suggest
The code itself as it stands is not very reusable so as a next step you should research using arguments so when you call the function at runtime you can supply the folder name and table name et cetera.
The code itself will search a particular folder for Excel files and attempts to import each file into Microsoft Access, using the filename as the table name.
How about creating a new Module and pasting the below code into it. Save it and name it whatever you want.
Public Function DoImport(strPath AS String, strTable AS String, _
blnHasFieldNames AS Boolean, RemoveFile AS Boolean)
Dim strFile As String
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, _
strPath & strFile, blnHasFieldNames
if RemoveFile Then Kill strPath & strFile
strFile = Dir()
Loop
End Function
Then you can call the function via the following:
DoImport "C:\imports\Excel\", "MyTableName", True, True
This allows you to pass the path, table name, whether the files contain field names and if you want to remove the file after import. That way you don't have to potentially change the code of the function constantly.
I intended to write a VBA function which would copy a .mdb file if a certain criterion is met.
I hit a roadblock when I realized the FileCopy method throws an error if the .mdb it is trying to copy/paste has an associated .ldb file.
However, I am able to manually copy/paste the .mdb through windows explorer.
The .mdb i am trying to copy will always be locked, since I have added a reference to it in the DB that is running the filecopy procedure.
Can someone show me how to force a copy programatically with VBA? I tried searching but all I found was advice against doing this because of DB corruption etc. BUT this won't be an issue, because none of the DB objects will be manipulated while this procedure is executing.
If anyone is curious, here is my procedure:
Function fn_ArchiveMonthEndDB()
'load INI data
fn_ReadINI
Dim asOfDate As Date
asOfDate = getAsOfDate()
Dim monthEndDate As Date
monthEndDate = fn_GetMonthEndDate()
sSQL = "SELECT CDate(Nz(LastRunDate,'1/1/1990')) as BackupDate FROM tbl_UseStats WHERE ProcessName = 'Archive Backend DB'"
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset(sSQL)
Dim dLastBackup As Date
dLastBackup = rs!BackupDate
rs.Close
Set rs = Nothing
If (dLastBackup <> monthEndDate) Then
'determine if it actually is month-end. if yes, then archive the DB.
If (asOfDate = monthEndDate) Then
'archive backend DB
sDir = iBackendArchive & "\" & CStr(Year(monthEndDate)) & CStr(Month(monthEndDate))
'create dir if it does not exist
If (Dir(sDir, vbDirectory)) = "" Then
MkDir sDir
End If
FileCopy iBackendPath & "\ETL_be.mdb", sDir & "\ETL_be.mdb"
Else
'if no, do nothing
End If
ElseIf (dLastBackup = monthEndDate) Then
'do nothing, because we already took a backup of the backend DB.
End If
End Function
Microsoft explains it pretty simply in their KB article.
- Create a module and type the following lines in the Declarations section:
Option Explicit
Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
- Type the following procedure:
Sub CopyFile(SourceFile As String, DestFile As String)
'---------------------------------------------------------------
' PURPOSE: Copy a file on disk from one location to another.
' ACCEPTS: The name of the source file and destination file.
' RETURNS: Nothing
'---------------------------------------------------------------
Dim Result As Long
If Dir(SourceFile) = "" Then
MsgBox Chr(34) & SourceFile & Chr(34) & _
" is not valid file name."
Else
Result = apiCopyFile(SourceFile, DestFile, False)
End If
End Sub
- To test this procedure, type the following line in the Immediate window, and then press ENTER:
CopyFile "<path to Northwind.mdb>", "C:\Northwind.mdb"
I have a front end and back end of an Access database. The front end references linked tables and I need to do a relative link instead of an explicit one i.e. "../database" is referenced instead of "address/database"
Is it possible to do this, or must I specify the absolute path?
Tables linked to files (such as mdb, accdb, dbf, etc.) require absolute paths in their connection strings.
However there is a workaround: during the database startup you can use vba to redefine the the links to match the directory of the current database instance.
(The code below has not been tested / debugged)
Private Sub RelinkTables()
Dim oldConnection As String
Dim newConnection As String
Dim currentPath As String
currentPath = CurrentProject.Path
Dim tblDef As TableDef
For Each tblDef In CurrentDb.TableDefs
oldConnection = tblDef.Connect
' Depending on the type of linked table
' some string manipulation which defines
' newConnection = someFunction(oldConnection,currentPath)
tblDef.Connect = newConnection
tblDef.RefreshLink
Next tblDef
End Sub
I have tried some of the answers above, especially the answer of Martin Thompson which I got some errors with, and thus modified it as follows:
Public Function reLinkTables() As Boolean
On Error GoTo ErrorRoutine
Dim sMyConnectString As String
Dim tdf As TableDef
Dim db_name As String
' The Main Answer is by Martin Thompson
' Modified by Dr. Mohammad Elnesr
'We will link all linked tables to an accdb Access file located in the same folder as this file.
'Replace the DATA file name in the following statement with the name of your DATA file:
sMyConnectString = ";DATABASE=" & CurrentProject.Path & "\"
For Each tdf In CurrentDb.TableDefs
If Len(tdf.Connect) > 0 Then
'It's a linked table, so re-link:
'First, get the database name
db_name = GetFileName(tdf.Connect)
' Then link the table to the current path
tdf.Connect = sMyConnectString & db_name
tdf.RefreshLink
End If
Next tdf
ExitRoutine:
MsgBox "All tables were relinked successfully"
Exit Function
ErrorRoutine:
MsgBox "Error in gbLinkTables: " & Err.Number & ": " & Err.Description
Resume ExitRoutine
End Function
Function GetFileName(FullPath As String) As String
Dim splitList As Variant
splitList = VBA.Split(FullPath, "\")
GetFileName = splitList(UBound(splitList, 1))
End Function
After fininshing this, Goto Access Ribon>Create>Macro From the dropdown select "RunCode", then in the function name type "reLinkTables" which we typed here. Then save the macro with the name "AutoExec". Every time you open the database, all the linked tables will be relinked to the original path. This is very useful if you put your databases in a portable media.
As far as I know, your TableDef's Connect property requires an absolute path. If I'm wrong on that point, I hope someone will tell how to create a linked table using a relative path.
Take a look at Armen Stein's free utility to manage your table links: J Street Access Relinker
Here is a simple routine that worked for me:
Public Function gbLinkTables() As Boolean
On Error GoTo ErrorRoutine
Dim sMyConnectString As String
Dim tdf As TableDef
'We will link all linked tables to an accdb Access file located in the same folder as this file.
'Replace the DATA file name in the following statement with the name of your DATA file:
sMyConnectString = ";database=" & CurrentProject.Path & "\Loan-Tracking-Data.accdb"
For Each tdf In CurrentDb.TableDefs
If Len(tdf.Connect) > 0 Then
'It's a linked table, so re-link:
tdf.Connect = sMyConnectString
tdf.RefreshLink
End If
Next tdf
ExitRoutine:
Exit Function
ErrorRoutine:
MsgBox "Error in gbLinkTables: " & Err.Number & ": " & Err.Description
Resume ExitRoutine
End Function
The following code has been tested in the Form_Load event of the form listed in the "Display Form" option for the database; that is the form that loads whenever the database is opened. This code could also be called from the AutoExec macro for the database:
Private Sub Form_Load()
Dim strOldConnect As String
Dim strNewConnect As String
Dim intSlashLoc As Integer
Dim intEqualLoc As Integer
Dim strConnect As String
Dim strFile As String
Dim strCurrentPath As String
strCurrentPath = CurrentProject.path
Dim tblDef As TableDef
Dim tblPrp As Property
For Each tblDef In CurrentDb.TableDefs
Debug.Print tblDef.Name
If tblDef.Connect & "." <> "." Then
strOldConnect = tblDef.Connect
intEqualLoc = InStr(1, strOldConnect, "=", vbTextCompare)
strConnect = Left(strOldConnect, intEqualLoc)
intSlashLoc = InStrRev(strOldConnect, "\", -1, vbTextCompare)
strFile = Right(strOldConnect, Len(strOldConnect) - intSlashLoc)
strNewConnect = strConnect & strCurrentPath & "\" & strFile
tblDef.Connect = strNewConnect
tblDef.RefreshLink
End If
Next tblDef
End Sub
you can make a "calculated" field.. works for me in Office Access 2016
"F:\Komponenten\Datenbank\Bilder\" & [Kategorie] & "\Pinout\" & [Bezeichnung] & ".jpg"
maybe there are better solutions, see images
calculated path
result