' arnelgp
'
' NOTE:
'
' Requirement is that Source table must have
' Autonumber field.
' Both Source and Archive table have same
' field names and type except that the
' equivalent field of Autonumber on source
' table is Normal Long to the Archive table.
'
' also the archive table must have a timestamp (date/time) field.
'
' not much documentation on the code so you need to figure it out.
'
Public Function fnArchive( _
ByVal stTable As String, _
ByVal stArchive As String, _
ByVal stTimeStampField As String, _
Optional ByVal stFilter As String = "")
' this will not test if all tables exists
Dim stSQL As String, stFields As String
Dim autoName As String
Dim db As DAO.Database
Dim rs As DAO.Recordset2
Dim rs2 As DAO.Recordset2
Dim chld As DAO.Recordset2
Dim chld2 As DAO.Recordset2
Dim fd As DAO.Field2, fd2 As DAO.Field2
Dim arrMV() As String
Dim arrTyp() As Integer
Dim i As Integer, j As Integer
Dim t As Variant
Dim sFile As String
fnArchive = True
t = Now
Set db = CurrentDb
ReDim arrMV(1 To 255): ReDim arrTyp(1 To 255)
' open structure of table to delete from
stSQL = "select * from [" & stTable & "] where (0=1);"
Set rs = db.OpenRecordset(stSQL, dbOpenSnapshot, dbReadOnly)
' loop through each fields on source table
' and check if there are multi-value or attachment fields.
With rs
For i = 0 To .Fields.Count - 1
Set fd = .Fields(i)
With fd
If .Attributes And dbAutoIncrField Then
'this is the autonumber field
autoName = .Name
stFields = stFields & "[" & .Name & "],"
Else
If .IsComplex Then
' multivalue or attachment field
' save the fieldname to our array
j = j + 1
arrMV(j) = .Name
' 0 = MVF '104
' 1 = attachment
arrTyp(j) = 0 - (.Type = 101)
Else
stFields = stFields & "[" & .Name & "],"
End If
End If
End With
Next
.Close
End With
Set rs = Nothing
Set fd = Nothing
If j <> 0 Then
ReDim Preserve arrMV(1 To j): ReDim Preserve arrTyp(1 To j)
End If
stFields = Left$(stFields, Len(stFields) - 1)
' append records to archive table
stSQL = "Insert Into [" & stArchive & "] (" & stFields
' add the timestamp field
stSQL = stSQL & ",[" & stTimeStampField & "]) Select " & stFields & ",p1 From [" & stTable & "]"
If Len(stFilter) <> 0 Then
stSQL = stSQL & " Where " & stFilter
End If
With db.CreateQueryDef("", stSQL)
.Parameters(0) = t
.Execute dbFailOnError
End With
If Not Err Then
' do we have MVF?
' handle Attachment and MVF
If j <> 0 Then
stFields = ""
For i = 1 To UBound(arrMV)
stFields = stFields & "[" & arrMV(i) & "],"
Next
stFields = Left$(stFields, Len(stFields) - 1)
stSQL = "select " & "[" & autoName & "]," & stFields & " from [" & stTable & "]"
If Len(stFilter) <> 0 Then
stSQL = stSQL & " Where " & stFilter
End If
Set rs = db.OpenRecordset(stSQL, dbOpenSnapshot)
stSQL = "select " & "[" & autoName & "]," & stFields & " from [" & stArchive & "] where [" & stTimeStampField & "]=#" & t & "#"
Set rs2 = db.OpenRecordset(stSQL, dbOpenDynaset)
With rs
.MoveFirst
Do Until .EOF
j = 0
rs2.FindFirst "[" & autoName & "] = " & .Fields(autoName).Value
rs2.Edit
For i = 1 To .Fields.Count - 1
j = j + 1
Set chld = .Fields(arrMV(j)).Value
Set chld2 = rs2.Fields(arrMV(j)).Value
If Not (chld.BOF And chld.EOF) Then
chld.MoveFirst
Do Until chld.EOF
chld2.AddNew
If arrTyp(j) = 0 Then
chld2.Fields(0) = chld.Fields(0)
Else
sFile = Environ$("temp") & "\" & chld.Fields("FileName")
If Len(Dir$(sFile)) <> 0 Then
Kill sFile
End If
chld.Fields("FileData").SaveToFile sFile
chld2.Fields("FileData").LoadFromFile sFile
End If
chld2.Update
chld.MoveNext
Loop
End If
Set chld2 = Nothing: Set chld = Nothing
Next i
rs2.Update
.MoveNext
Loop
.Close
End With
rs2.Close
End If
' finally, delete the records from the source
stSQL = "delete [" & stTable & "].* from [" & stTable & "]"
If Len(stFilter) <> 0 Then
stSQL = stSQL & " Where " & stFilter
End If
db.Execute stSQL, dbFailOnError
Else
fnArchive = False
End If
Set rs = Nothing
Set rs2 = Nothing
Set db = Nothing
End Function
