Option Compare Database
Public Type RecRelation
rName As String
rAttr As Integer
rTable As String
rFtable As String
rFields As DAO.Fields
End Type
Function ImportRecords()
Dim recRel() As RecRelation
Dim Rel As Relation, fld As DAO.Field
Dim k As Integer, j As Integer
Dim strSource As String
Dim tbl As TableDef
Dim s As String
strSource = fFileDialogAns(msoFileDialogFilePicker, "", "", "Access Database", "*.accdb;*.mdb")
If strSource = "" Then Exit Function
'strSource = CurrentProject.Path & "\old.mdb"
If CheckTableMatch(strSource) Then
If MsgBox("ãíÓÑ¡ ÌÏÇæá æ ÝíáÏåÇí ãÈÏÇ ÕÍíÍ ÇÓÊ . ÈÇ ÌÇíÒíäí ÇØáÇÚÇÊ ÌÏÇæá ãæÇÝÞ åÓÊíÏ¿", vbYesNo + vbExclamation + vbMsgBoxRight) = vbNo Then Exit Function
Else
Exit Function
End If
k = CurrentDb.Relations.Count
DoCmd.SetWarnings False
If k Then
k = k - 1
ReDim recRel(k)
k = 0
For Each Rel In CurrentDb.Relations
recRel(k).rAttr = Rel.Attributes
recRel(k).rName = Rel.Name
recRel(k).rTable = Rel.Table
recRel(k).rFtable = Rel.ForeignTable
p = Rel.Fields.Count
Set recRel(k).rFields = Rel.Fields
CurrentDb.Relations.Delete Rel.Name
k = k + 1
Next Rel
End If
'On Error Resume Next
'DELETE Tables content & insert
For Each tbl In CurrentDb.TableDefs
If tbl.Attributes = 0 Then
'this part need change !!!!!!!!!!!!!!! somthing like below ofcource after import tables!!!!!!!!!!!!!!!!!!!!!!!!!!
strSQL = "UPDATE" & tbl.Name & "RIGHT JOIN" & tbl.Name & "ON" & tbl.Name.key1 = tbl.Name.key1 And tbl.Name.key2 = tbl.Name.key2 & "SET tblData.StartDate = [tblImport].StartDate, tblData.EndDate = [tblImport].EndDate, tblData.NCheck = tblImport.[NCheck];"
DoCmd.RunSQL strSQL
' strSQL = "INSERT INTO " & tbl.Name & " SELECT * FROM " & tbl.Name & " IN '" & strSource & "'"
' DoCmd.RunSQL strSQL
End If
Next
If k Then
'On Error GoTo 0
For k = 0 To UBound(recRel)
Set Rel = CurrentDb.CreateRelation(recRel(k).rName, recRel(k).rTable, recRel(k).rFtable, recRel(k).rAttr)
For j = 0 To recRel(k).rFields.Count - 1
Set fld = Rel.CreateField(recRel(k).rFields(j).Name)
fld.ForeignName = recRel(k).rFields(j).ForeignName
Rel.Fields.Append fld
Next
CurrentDb.Relations.Append Rel
Next
End If
DoCmd.SetWarnings True
MsgBox "ÚãáíÇÊ ÌÇíÒíäí ÈÇ ãæÝÞíÊ Èå ÇíÇä ÑÓíÏ"
End Function
Function GetFieldVal(tdf As String, fld As String, Optional Criteria As String = " (1) ", Optional ExternalDb As String = "") As Variant
Dim rs As DAO.Recordset
Dim db As Database
Dim strSQL As String
If ExternalDb <> "" Then
Set db = DBEngine.OpenDatabase(ExternalDb)
Else
Set db = CurrentDb
End If
strSQL = "SELECT " & fld & " FROM " & tdf & " WHERE " & Criteria
Set rs = db.OpenRecordset(strSQL)
GetFieldVal = Nz(rs.Fields(0))
End Function
Function CheckTableMatch(ExternalDb As String) As Boolean
Dim db As Database, tbl As DAO.TableDef, fld As DAO.Field, ExFld As DAO.Field
Dim blnFldMatch As Boolean, k As Integer
If Dir(ExternalDb) = "" Then
MsgBox "ÝÇíá ãÈÏÇ æÌæÏ äÏÇÑÏ"
Exit Function
End If
Set db = DBEngine.OpenDatabase(ExternalDb)
For Each tbl In CurrentDb.TableDefs
If tbl.Attributes = 0 Then
k = GetFieldVal("MSysObjects", "Count(*)", "Name = '" & tbl.Name & "' AND (Type = 1) ", ExternalDb)
If k = 0 Then
MsgBox "ÇäÌÇã ÚãáíÇÊ ÈÚáÊ ÚÏã æÌæÏ ÌÏæá(åÇ) Çã˜Çä ÐíÑ äãí ÈÇÔÏ"
Exit Function
Else
For Each fld In tbl.Fields
blnFldMatch = False
For Each ExFld In db.TableDefs(tbl.Name).Fields
If ExFld.Name = fld.Name Then blnFldMatch = True
Next ExFld
If Not blnFldMatch Then
MsgBox "ÇäÌÇã ÚãáíÇÊ ÈÏáíá ÚÏã ÊØÇÈÞ ÝíáÏ Çã˜Çä ÐíÑ äãí ÈÇÔÏ"
Exit Function
End If
Next fld
End If
End If
Next tbl
Set db = Nothing
CheckTableMatch = True
End Function
Function MissedID(tdfName As String, fldName As String)
Dim strSQL As String, k As Integer
Dim rs As DAO.Recordset
Dim ListOfID() As Integer, j As Integer
Set rs = CurrentDb.OpenRecordset(tdfName)
With rs
.MoveLast
.MoveFirst
k = rs.Fields(fldName)
For k = k To .RecordCount
If k <> .Fields(fldName) Then
ReDim Preserve ListOfID(j)
ListOfID(j) = k
j = j + 1
End If
.MoveNext
Next
.Close
End With
Set rs = Nothing
MissedID = ListOfID
End Function
Public Function fFileDialogAns(dlgType As MsoFileDialogType, Optional sPath As String = "", Optional sFileName As String = "", _
Optional sFilterDesc As String = "", Optional sFilterExtention As String = "", Optional MultiSel As Boolean) As String
Dim dlg As FileDialog
Dim varSelItems As Variant
Dim k As Integer, s As String, S2 As String, strOpenFile As String
fFileDialogAns = ""
Set dlg = Application.FileDialog(dlgType)
dlg.AllowMultiSelect = MultiSel
If dlgType = msoFileDialogSaveAs Then
dlg.title = "ÐÎíÑå ÝÇíá"
dlg.InitialFileName = sPath & "\" & sFileName
dlg.ButtonName = "ÐÎíÑå"
ElseIf dlgType = msoFileDialogFilePicker Then
dlg.title = "ÇäÊÎÇÈ ÝÇíá"
dlg.Filters.Add sFilterDesc, sFilterExtention, 1
dlg.InitialFileName = sPath
dlg.ButtonName = "ÇäÊÎÇÈ"
Else
dlg.title = "ÇäÊÎÇÈ æÔå"
dlg.InitialFileName = sPath & "\"
End If
If dlg.Show = True Then
'dlgType=msoFileDialogFolderPicker
'strOpenFile = dlg.InitialFileName
Else
Set dlg = Nothing
Exit Function
End If
sPath = ""
For Each varSelItems In dlg.SelectedItems
sPath = sPath & varSelItems & ";"
Next
sPath = Left(sPath, Len(sPath) - 1)
Set dlg = Nothing
If dlgType = msoFileDialogFilePicker Or dlgType = msoFileDialogFolderPicker Then
fFileDialogAns = sPath
Exit Function
End If
' verify extention
k = InStrRev(sPath, ".")
s = Right(sPath, Len(sPath) - k)
k = InStrRev(sFileName, ".")
S2 = Right(sFileName, Len(sFileName) - k)
If s <> S2 Then Exit Function
fFileDialogAns = sPath
End Function
