Here is the specific error Line:
CurrentDb.Execute "INSERT INTO " & strImportHoldingTable & _
" SELECT " & strImportTable & ".* " & _
"FROM " & strImportTable
Error:
Run time error '3611':
Cannot execute data definintion statements on linked data source.
Line 203,Col1
127 Select Case strImportTable
Case "tmp_Attendance"
CurrentDb.Execute ("ALTER TABLE " & strImportHoldingTable & " ALTER COLUMN SNUM Text") 'Ensure SNUM is in text format
End Select 'Append the records. Iterate through the recordset to get each field name to run the append query
All Code:
Option Compare Database
Option Explicit
Public Function LocateFiles()
'*******************************************************************************************************'
'Function to allow for multiple file selections. Function determines which form is currently being used '
'and performs appropriate actions such as populating list-box for the current form that is open and '
'being used. *****Data Gopher 8/3/2011 '
'*******************************************************************************************************'
'On Error GoTo Err_Error_Handling
'Variables to identify current open form
Dim frmCur As Form
Dim objFrm As Object
Dim varFrm As Variant
Dim strcurfrm As String
'Locate file variables
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim varFileName As Variant
Dim varFilePath As String
'Variables to pass values
Dim intRetVal As Integer
'Get the current form that is being used
100 Set objFrm = Application.Forms 'All forms collection
101 For Each frmCur In objFrm 'Loop all forms to fine the one that is open
102 If Forms(frmCur.Name).CurrentView <> 0 Then
103 strcurfrm = frmCur.Name
104 End If
105 Next frmCur
'Perform the file selection portion
'Clear listbox contents.
'Forms!frm_Upload_Attendance.lstFiles.RowSource = ""
110 Forms(strcurfrm).lstFiles.RowSource = ""
111 Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
112 With fDialog
'Allow user to make multiple selections in dialog box
113 .AllowMultiSelect = True
'Set the title of the dialog box.
114 .Title = "Please select one or more files to import"
'Clear out the current filters, and add our own.
115 .Filters.Clear
116 .Filters.Add "Excel Spreadsheets", "*.XLS,*.XLSX"
'Ensure the user selects atleast one file
120 If .Show = True Then
'iterate through all selections and add to the list box
121 For Each varFile In .SelectedItems
122 varFileName = Split(varFile, "\")
123 varFileName = varFileName(UBound(varFileName))
124 varFilePath = varFile & "," & varFileName
125 Forms(strcurfrm).lstFiles.AddItem varFilePath
126 Next
127 Else
128 MsgBox "You clicked Cancel in the file dialog box."
129 End If
130 End With
'Error trapping
Exit_Error_Handling:
Exit Function
Err_Error_Handling:
MsgBox Err.Description
Resume Exit_Error_Handling
' intRetVal = GetSelections(strcurfrm)
End Function
Public Function GetSelections()
'***************************************************************************************************************************'
'Gets the current form that is open and iterates through the list box to get each file that was selected and then passes '
'the values to a separate function for importing. *****Data Gopher 8/3/2011 '
'***************************************************************************************************************************'
'On Error GoTo Err_Error_Handling
'Form variables
Dim frmCur As Form
Dim objFrm As Object
Dim strcurfrm As String
'List Box variables
Dim x As Integer
Dim ctlFiles As Control
Dim strFileName As String
'Variables to pass values to other functions
Dim intRetVal As Integer
Dim strImportTable As String
Dim strImportHoldingTable As String
Dim intImportCount As Integer
Dim strDBTable As String
Dim strFileAdd As String
Dim dtDate As Date
Dim intTotalCount As Integer
'Set to the current date
dtDate = Date
'Dim intImportCount As Integer
'Reset the count
intImportCount = 1
'Get the current form that is being used
100 Set objFrm = Application.Forms 'All forms collection
101 For Each frmCur In objFrm 'Loop through all forms to find the one that is open
102 If Forms(frmCur.Name).CurrentView <> 0 Then
103 strcurfrm = frmCur.Name
104 End If
105 Next frmCur
106 strImportTable = "tmp_" & Mid(strcurfrm, 12, Len(strcurfrm) - 11) 'Get the name of the import table
107 strImportHoldingTable = strImportTable & "_Holding"
108 strDBTable = "tbl_" & Mid(strcurfrm, 12, Len(strcurfrm) - 11) 'Get the name of the import table
'Set the control
110 Set ctlFiles = Forms(strcurfrm).lstFiles
111 For x = 0 To ctlFiles.ListCount - 1
112 strFileName = ctlFiles.ItemData(x)
113 intRetVal = ImportOps(strImportTable, strImportHoldingTable, strFileName, intImportCount, strDBTable)
'Append to the import history. Added 1/2/2012
strFileAdd = Mid(strcurfrm, 12, Len(strcurfrm) - 11)
intTotalCount = DCount("*", strImportTable)
CurrentDb.Execute "INSERT INTO tbl_Import_History ( ih_File_Name, ih_Import_Date, ih_Total_Records ) " & _
"VALUES (""" & strFileAdd & """, #" & Date & "#, " & intTotalCount & ")"
114 intImportCount = intImportCount + 1
115 Next x
DoCmd.OpenTable "tbl_Import_History"
intRetVal = CheckForNew(strImportTable, strDBTable, strImportHoldingTable)
'Error trapping
Exit_Error_Handling:
Exit Function
Err_Error_Handling:
MsgBox Err.Description
Resume Exit_Error_Handling
End Function
Public Function ImportOps(strImportTable As String, _
strImportHoldingTable As String, _
strFileName As String, _
intImportCount As Integer, _
strDBTable As String)
'***************************************************************************************************************'
'The name of the file to import and table to import is passed from the Function GetSelections. First a check '
'is performed to determine if the import table already exists and if it does, it's deleted. Each file is then '
'imported to its respective table. *****Dan Hafdelin 8/4/2011 '
'***************************************************************************************************************'
'On Error GoTo Err_Error_Handling
Dim objTbl As Object
Dim tdf As TableDef
Dim strField As String
Dim strFieldSQL As String
Dim strFieldInsertSQL As String
Dim strFieldHoldingSQL As String
Dim fld As Field
Dim dbs As Database
Set dbs = CurrentDb
Dim intRetVal As Integer
'Check to deterimine if the import table exists and if so delete it
100 For Each objTbl In CurrentDb.TableDefs
101 If objTbl.Name = strImportTable Then
102 DoCmd.DeleteObject acTable, strImportTable
103 End If
104 Next objTbl
'Import the spreadsheet
110 DoCmd.TransferSpreadsheet acImport, , strImportTable, strFileName, -1
'Check if the temporary holding table exists and if so and this is the first file being imported, it is deleted
'120 If intImportCount = 1 Then
'121 For Each objTbl In CurrentDb.TableDefs
'122 If objTbl.Name = strImportHoldingTable Then
'123 DoCmd.DeleteObject acTable, strImportHoldingTable
'124 End If
'125 Next objTbl
'126 CurrentDb.Execute "SELECT " & strImportTable & ".* INTO " & strImportHoldingTable & _
' " FROM " & strImportTable
'If a first pass then delete records from holding table
If intImportCount = 1 Then
CurrentDb.Execute "DELETE " & strImportHoldingTable & ".* " & _
"FROM " & strImportHoldingTable
End If
CurrentDb.Execute "INSERT INTO " & strImportHoldingTable & _
" SELECT " & strImportTable & ".* " & _
"FROM " & strImportTable
127 Select Case strImportTable
Case "tmp_Attendance"
CurrentDb.Execute ("ALTER TABLE " & strImportHoldingTable & " ALTER COLUMN SNUM Text") 'Ensure SNUM is in text format
End Select 'Append the records. Iterate through the recordset to get each field name to run the append query
'Iterate through the table to get each field name
131 Set tdf = dbs.TableDefs(strImportHoldingTable)
132 For Each fld In tdf.Fields
133 strField = "[" & fld.Name & "], "
134 strFieldSQL = strFieldSQL & strField
135 strFieldInsertSQL = strFieldInsertSQL & strImportTable & "." & strField
136 Next fld
137 strFieldSQL = Left(strFieldSQL, Len(strFieldSQL) - 2)
138 strFieldInsertSQL = Left(strFieldInsertSQL, Len(strFieldInsertSQL) - 2)
'End If
'Add New Records
'intRetVal = CheckForNew(strImportTable, strFieldSQL, strDBTable, strFieldHoldingSQL, strImportHoldingTable)
'Import the file(s) to the temporary table and then append to holding records table
'Error trapping
Exit_Error_Handling:
Exit Function
Err_Error_Handling:
MsgBox Err.Description
Resume Exit_Error_Handling
End Function
Public Function CheckForNew(strImportTable As String, _
strDBTable As String, _
strImportHoldingTable As String)
Dim strNewRecs As String
Dim strMatching As String
Dim strCleanRecs As String
Dim strRemaining As String
Dim strUpdate As String
Dim strDelBlank As String
'Delete existing records
'Clean Temp records
strDelBlank = "qdel_Blank_" & strImportTable
strNewRecs = "qapp_NR_" & strImportTable
'Delete extra spaces
CurrentDb.Execute strDelBlank, dbFailOnError
'Add new records and update information
CurrentDb.Execute strNewRecs, dbFailOnError
'Append remaining records after update
strRemaining = "qapp_Rem_" & strImportTable
CurrentDb.Execute strRemaining, dbFailOnError
'Update the records
strUpdate = "qupd_" & strImportTable
'CurrentDb.Execute strRemaining, dbFailOnError
End Function
Jim
