Γιώργο σε ευχαριστώ πολύ για την απάντηση σου. Θα δοκιμάσω το τρόπο που μου αναφέρεις αν και είδα οτι δεν έχει έλεγχο αν η στήλη υπάρχει. Όπως και να έχει θα δοκιμάσω και θα σου πώ εντυπώσεις.
Το πρώτο πόστ το έκανα να δουλέψει μέχρι ένα σημείο αλλά δεν μπόρεσα ακόμη να το κάνω να κάνει ξανά εισαγωγή τον πίνακα.
Option Compare Database
'---------------------------------------------------------------------------------------
' Procedure : subAddTableField
' Author : Neville Turbit
' Date : 21/01/2011
' Purpose : Add a new field to a linked table
'---------------------------------------------------------------------------------------
'
Public Sub subAddTableField(strTableName As String, strFieldName As String, strFieldType As String, Optional strIndex As String)
Dim dbs As Database
Dim strSQL As String
Dim strTablesDatabase As String
Dim tdfLinked As TableDef
On Error GoTo Error_subAddTableField
'---------------------------------------------------------------
' If the table does not exist, exit
If funTableExists(strTableName) = False Then
MsgBox "Ï ðßíáêáò ðïõ æçôÞóáôå äåí õðÜñ÷åé.", vbOKOnly, "ÅíçìÝñùóç"
GoTo Exit_subAddTableField
End If
'---------------------------------------------------------------
' If a local table exists delete it. Checks if table is linked
strTablesDatabase = funGetLinkedDBName(strTableName)
If strTablesDatabase = CurrentDb.Name Then
DoCmd.DeleteObject acTable, strTableName ' Delete the table Could be left over from previous modification. Not likely but best to be safe.
End If
'---------------------------------------------------------------
' Check if the field exists. If it fails proceed with the table modification
On Error GoTo Insert_Field ' If error, the field does not exist
strSQL = "SELECT " & strTableName & "." & strFieldName & " FROM " & strTableName & ";"
Set dbs = CurrentDb
dbs.OpenRecordset strSQL, dbOpenSnapshot, dbSeeChanges
Exit_subAddTableField:
On Error GoTo 0
Exit Sub
Insert_Field:
'---------------------------------------------------------------
' Delete the link (not the table)
Set tdfLinked = dbs.TableDefs(strTableName) ' Select a table. If no database, this will fail.
DoCmd.DeleteObject acTable, tdfLinked.Name ' Delete the link to the table
'---------------------------------------------------------------
' Import, modify and export the table
DoCmd.TransferDatabase acImport, "Microsoft Access", strTablesDatabase, acTable, strTableName, strTableName
strSQL = "ALTER TABLE " & strTableName & " ADD COLUMN " & strFieldName & " " & strFieldType & " " & Nz(strIndex, "")
subRunUpdateQuery (strSQL)
DoCmd.TransferDatabase acExport, "Microsoft Access", strTablesDatabase, acTable, strTableName, strTableName
'---------------------------------------------------------------
' Relink the table
DoCmd.DeleteObject acTable, tdfLinked.Name ' Delete the link
subLinkToOneBETable strTableName, strTablesDatabase ' Relink the table
GoTo Exit_subAddTableField
Error_subAddTableField:
MsgBox "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Module Name: modReleaseSetup" & vbCrLf & _
"Type: Module" & vbCrLf & _
"Calling Procedure: subAddTableField" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Resume Exit_subAddTableField
Resume
End Sub
Public Sub subRunUpdateQuery(strSQL As String)
' Run a query in the sql string passed to the sub to update some data
On Error GoTo Error_subRunUpdateQuery
DoCmd.Hourglass (True) ' Turn on the hourglass
DoCmd.SetWarnings False
Set dbs = CurrentDb
Set qdf = dbs.CreateQueryDef("", strSQL) ' Create new QueryDef.
qdf.Execute dbSeeChanges
' Run the insert query
Exit_subRunUpdateQuery:
Set dbs = Nothing 'Clean up
Set qdf = Nothing
strSQL = ""
DoCmd.Hourglass (False) ' Turn off the hourglass
DoCmd.SetWarnings True
Exit Sub
Error_subRunUpdateQuery:
MsgBox "Error in subRunUpdateQuery: " & Err.Number & " - " & Err.Description
Resume Exit_subRunUpdateQuery
End Sub
'---------------------------------------------------------------------------------------
' Procedure : funTableExists
' Author : Neville Turbit
' Date : 04/06/09
' Purpose : Check if the table is already in this Database
'---------------------------------------------------------------------------------------
'
Public Function funTableExists(strTblName As String) As Boolean
Dim dbs As Database
Dim tbl As TableDef
Dim dbsExist As Object
On Error GoTo Error_funTableExists
funTableExists = False
Set dbs = CurrentDb
Set dbsExist = dbs.TableDefs
'--------------------------------------------------------------
' Search for AccessObject objects in AllTables collection.
For Each tbl In dbsExist
If tbl.Name = strTblName Then
funTableExists = True ' Set the function to true
GoTo Exit_funTableExists ' Quit if true
End If
Next tbl
Exit_funTableExists:
On Error GoTo 0
Set dbsExist = Nothing ' Clean up
Exit Function
Error_funTableExists:
MsgBox "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Module Name: modGeneric" & vbCrLf & _
"Type: Module" & vbCrLf & _
"Calling Procedure: funTableExists" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Resume Exit_funTableExists
Resume
End Function
'---------------------------------------------------------------------------------------
' Procedure : funGetLinkedDBName
' Author : Neville Turbit
' Date : 10/11/2010
' Purpose : The funGetLinkedDBName() function requires the name of a
' linked Microsoft Access table, in quotation marks, as an
' argument. The function returns the full path of the originating
' database if successful, or returns 0 if unsuccessful.
'---------------------------------------------------------------------------------------
'
Public Function funGetLinkedDBName(TableName As String)
Dim dbs As DAO.Database
Dim varReturn As Variant
On Error GoTo Error_NoTable ' Handles table not found
'---------------------------------------------------------------
' Find the table
Set dbs = CurrentDb()
varReturn = dbs.TableDefs(TableName).Connect
On Error GoTo Error_funGetLinkedDBName ' Normal error handling
'---------------------------------------------------------------
' Remove the "Database=" from the returned value
funGetLinkedDBName = Right(varReturn, Len(varReturn) - (InStr(1, varReturn, "DATABASE=") + 8))
Exit_funGetLinkedDBName:
On Error GoTo 0
Exit Function
Error_NoTable:
funGetLinkedDBName = "0"
GoTo Exit_funGetLinkedDBName
Error_funGetLinkedDBName:
MsgBox "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Module Name: modGeneric" & vbCrLf & _
"Type: Module" & vbCrLf & _
"Calling Procedure: funGetLinkedDBName" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Resume Exit_funGetLinkedDBName
Resume
End Function
'---------------------------------------------------------------------------------------
' Procedure : subLinkToOneBETable
' Author : Neville Turbit
' Date : 21/01/2011
' Purpose : Link one back end table
'---------------------------------------------------------------------------------------
'
Public Sub subLinkToOneBETable(strTableName As String, strBEPath As String)
Dim dbs As Database
Dim tdf As TableDef ' Tables in this database
Dim tdfLinked As TableDef ' Tables in back end database
Dim strPW As String
'--------------------------------------------------------------
' Check it is a valid path
On Error GoTo Error_subLinkToOneBETable
If funTableExists(strBEPath) = False Then
Call MsgBox("The path provided for the back end database is incorrect. Please ensure the correct path is provided. " _
& vbCrLf & "" _
& vbCrLf & "See your System Administrator." _
, vbCritical, "Missing Database")
GoTo Exit_subLinkToOneBETable
End If
'--------------------------------------------------------------
' Clean up
Set tdf = Nothing
Set dbs = Nothing
'--------------------------------------------------------------
' Relink the files
Set dbs = OpenDatabase(strBEPath, False, False) ' This will fail if there is a password on the BE
Set tdfLinked = dbs.TableDefs(strTableName) ' Select a table. If no database, this will fail.
If funCheck4Nothing(tdfLinked.Name) = True Then ' No tabledef exists
strPW = InputBox("Please enter the database password." & _
" If you do not know the password, see your System Administrator.", _
"Database Password") ' Ask for the password
Set dbs = OpenDatabase(strBEPath, False, False, ";pwd=" & strPW) ' Open the database using the password
End If
If funTableExists(tdfLinked.Name) Then
DoCmd.DeleteObject acTable, tdfLinked.Name
End If
DoCmd.TransferDatabase acLink, "Microsoft Access", _
strBEPath, acTable, tdfLinked.Name, tdfLinked.Name ' Link the table
DoCmd.Hourglass False
Exit_subLinkToOneBETable:
On Error GoTo 0
Exit Sub
Error_subLinkToOneBETable:
MsgBox "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Module Name: modGeneric" & vbCrLf & _
"Type: Module" & vbCrLf & _
"Calling Procedure: subLinkToOneBETable" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Resume Exit_subLinkToOneBETable
Resume
End Sub
'---------------------------------------------------------------------------------------
' Procedure : funCheck4Nothing
' Author : Neville Turbit
' Date : 04/06/09
' Purpose : Check the value passed is null, zero string ("") or zero. Returns true if any of these.
'---------------------------------------------------------------------------------------
'
Public Function funCheck4Nothing(var As Variant)
On Error GoTo Error_funCheck4Nothing
If IsNull(var) Or var = "" Or var = 0 Then
funCheck4Nothing = True
Else
funCheck4Nothing = False
End If
Exit_funCheck4Nothing:
On Error GoTo 0
Exit Function
Error_funCheck4Nothing:
MsgBox "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Module Name: modGeneric" & vbCrLf & _
"Type: Module" & vbCrLf & _
"Calling Procedure: funCheck4Nothing" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Resume Exit_funCheck4Nothing
Resume
End Function
 |