I have a few Lotus Notes 'databases' that i'd like to import into Access or SQL.
I think I have most of the steps down (install NotesSQL ODBC driver, setup ODBC connection to Lotus DB, import data into Access), but I can't figure out what to do with all the documents, eg: Word Files, PDF Docs, Excel Workbooks that were in the Lotus DB.
The Lotus Notes DB is full of them. After importing, I do notice a table in Access called 'Documents,' but I don't know what to do with it. I see a line/record for each document in the Lotus DB, but it's not like SQL where there is a column for the actual file data.
Please let me know how I can actually use the documents I pull out of the Lotus DB.
Your best bet is to extract the documents from the database and store them on a file share. That will give you the most flexibility. To retain the association with the original Notes documents, you may want to export them with filenames or into folders with folder names that include the ID of the associated record in Access. Or at least make sure the records include the path of the document.
I don't believe you can pull in attachments via the NotesSQL driver.
Here's an example script that you can put into an Agent to extract attachments from your database: (from http://www.notes411.com/dominosource/tips.nsf/0/4F1FF33C52F08D76802570C2003A2FD6!opendocument)
Sub Initialize
Dim session As New NotesSession
Dim db As NotesDatabase
Dim collection As NotesDocumentCollection
Dim doc As NotesDocument
Set db = session.CurrentDatabase
Set collection = db.UnprocessedDocuments
Set doc = collection.GetFirstDocument()
While Not(doc Is Nothing)
Call extractMyAttachment( doc )
Set doc = collection.GetNextDocument(doc)
Wend
End Sub
Function extractMyAttachment (doc)
Dim emb As Variant
Dim nid As String
nid = doc.NoteID
Dim rtitem As Variant
Set rtitem = doc.GetFirstItem( "Body" )
Dim pathName As String, fileName As String, mydir As String,
newfilename As String
mydir = "Coda"
pathName$ = "P:\" & mydir
fileName$ = Dir$(pathName$, 16)
Dim boxType As Long, answer As Integer
boxType& = 36
If fileName$ = "" Then
answer% = Messagebox("Directory "& pathName$ &" does not exist,
would you like to create it ?", boxType&, "Create" & mydir & " on P:\ ?")
If answer% = 6 Then
Mkdir pathname$
fileName$ = Dir$(pathName$, 16)
If filename$ <> "" Then
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
newfilename$ = pathname$ & "\" &
o.source
Call o.ExtractFile (newfilename$
)
End If
End Forall
End If
End If
End If
Else
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
newfilename$ = pathname$ & "\" & o.source
fileName$ = Dir$(NewFileName$, 0)
If fileName$ <> "" Then
answer% = Messagebox("File "&
NewFileName$ &" already exists, would you like to overwirite it ?",
boxType&, "Overwrite" & NewFileName$ & " ?")
If answer% = 6 Then
Call o.ExtractFile (newfilename$
)
End If
Else
Call o.ExtractFile (newfilename$ )
End If
End If
End Forall
End If
End If
End Sub
Related
I've got a bit of VBA running in access. Its purpose is to output a pipe delineated string in order to provide exports/back ups of existing tables. It's working well but there's another feature I'd like to add. One of the tables it may be run against contains attachments and I would like the attachment filename to appear under the 'attachment' field. Currently the code just sticks a warning in there but I'd like something more relevant.
The code currently reads each field name in the designated table, splitting them with a pipe (|). It then goes to a new line and repeats the process with the values in each field. Relevant bit of code below:
Set rs = CurrentDb.OpenRecordset(Table, dbOpenSnapshot)
rs.Filter = srchString
Set rsFilt = rs.OpenRecordset()
fieldCount = rsFilt.Fields.Count
recordTot = rsFilt.RecordCount
If recordTot <> 0 Then
rsFilt.MoveFirst
Dim o As Integer
For o = 0 To fieldCount - 1
fieldNames = fieldNames & rsFilt.Fields(o).Name & "|"
Next o
Do While rsFilt.EOF = False
For o = 0 To fieldCount - 1
If rsFilt.Fields(o).Type <> 101 Then
oldDataSet = oldDataSet & Nz(rsFilt.Fields(o).Value, "") & "|"
Else
oldDataSet = oldDataSet & "attached files not saved in logs" & "|"
End If
Next o
oldDataSet = oldDataSet & vbNewLine
rsFilt.MoveNext
Loop
Else
fieldNames = "No " & Table & " for this member."
End If
createRecordSnapshot = fieldNames & vbNewLine & oldDataSet
End Function
Each record has only one attachment associated with it. I'd like some way to fetch that filename as a string.
Many thanks,
As best I can tell, the only way to access this information is through an Attachment control on a Form. You could make a simple form with just this control on it, load it as part of your code and access it in the loop.
Here's an example of looping through the records in a form and reading the filename property of the Attachment control:
Dim frm As Form
Dim ctl As Attachment
Dim i As Long, j As Long
Set frm = Application.Forms("Form1")
Set ctl = frm.Controls("test") 'An Attachment control
frm.RecordsetClone.MoveLast
i = frm.Recordset.RecordCount
For j = 0 To i - 1
Debug.Print ctl.FileName
DoCmd.GoToRecord acDataForm, frm.Name, acNext
Next
I have a list of file names in a worksheet. I want to read a name, find the actual file, rename it and move on to the next name.
The 1st part, retrieving the name from the worksheet and modifying it to the new name is not a problem. The problem is assigning the new name to the file.
The Name function does not work because the files are on a different drive. I also tried Scripting.FileSystemObject.
The code runs but no change is made.
Here is the code I used...
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(fOldName)
If Not Err = 53 Then 'File not found
'Rename file
f.Name = fNewName
End If
Did I make a code mistake I'm not seeing? Should I be using/doing something else?
Finding info on VBA and/or VB6 is getting pretty rare these days.
BTW. This is for Excel 2016.
Tks
If there was no misunderstanding...
FSO... it's bad in any case. It's just a bugsful API wrapper, written with a left chicken paw.
There are pure VB & API for more sophisticated cases.
No external libs & objects:
Public Sub sp_PrjFilMov()
Dim i As Byte
Dim sNam$, sExt$, sPthSrc$, sPthTgt$, sDir$
sPthSrc = "V:\"
sPthTgt = "R:\"
sNam = "Empty_"
sExt = ".dmy" ' dummy
For i = 1 To 5 ' create set of files for test
Call sx_CrtFil(i, sPthSrc, sNam, sExt)
Next
sDir = Dir(sPthSrc & "*" & sExt, vbNormal) ' lookup for our files ..
Do
'Debug.Print sDir
Select Case LenB(sDir)
Case 0
Exit Do ' *** EXIT DO
Case Else
Call sx_MovFil(sPthSrc, sDir, sPthTgt) ' .. & move them to another disk
sDir = Dir
End Select
Loop
Stop
End Sub
Private Sub sx_CrtFil(pNmb As Byte, pPth$, pNam$, pExt$)
Dim iFilNmb%
Dim sFilNam$
sFilNam = pPth & pNam & CStr(pNmb) & pExt
iFilNmb = FreeFile
Open sFilNam For Output As #iFilNmb
Close #iFilNmb
End Sub
Private Sub sx_MovFil(pPnmSrc$, pFnm$, pPthTgt$)
Dim sSrcPne$
sSrcPne = pPnmSrc & pFnm
'Debug.Print "Move " & sSrcPne & " --> " & pPthTgt
Call FileCopy(sSrcPne, pPthTgt & pFnm)
Call Kill(sSrcPne)
End Sub
'
I am running MS Access 2010. Using VBA I am trying to pull attachments out of MS Exchange 2013 and insert them into the Access table "TBL_APPT_ATTACHMENT".
The table "TBL_APPT_ATTACHMENT" looks like this:
Attachment_title Memo
Attachment_filename Memo
Attachment_blob OLE Object
Everything seems to work correctly except I can not figure out how to save the actual file into the column ATTACHMENT_BLOB. Here is my VBA function that I am calling (See question marks below).
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
Call MsgBox("FileName: " & Attachment.FileName, vbOKOnly, "Error")
Call MsgBox("DisplayName: " & Attachment.DisplayName, vbOKOnly, "Error")
Call MsgBox("Index: " & Attachment.Index, vbOKOnly, "Error")
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
rsAttID = rsAtt!ID
rsAtt.Update
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
Set rsParent = CurrentDb.OpenRecordset("SELECT ID, ATTACHMENT_BLOB FROM TBL_APPT_ATTACHMENT WHERE ID = " & rsAttID)
rsParent.OpenRecordset
Do While Not rsParent.EOF
rsParent.Edit
'Load file into Database.
'??? This next statement gives me a "Type Mismatch" error. Why?????
Set rsChild = rsParent.Fields("ATTACHMENT_BLOB").Value
rsChild.AddNew
rsChild.Fields("FileData").LoadFromFile (filePath)
rsChild.Update
rsParent.Update
rsParent.MoveNext
Loop
Next
End Function
Thanks!!
Remember that the attachment is really a file (whether its an OLE object or not). While it may be possible to perform a copy-paste of the object from Outlook into Access, my recommendation is to save the attachment as a file:
dim filepath as String
dim filename as String
filepath = "C:\appropriatefolder\"
filename = Attachment.FileName
Attachment.SaveAsFile filepath & filename
Now you're in a position to save the attachment in Access, but I seriously don't recommend using the Attachment field type. It can be rather tricky to use. So my solution to the same problem was to create a field of type Hyperlink. Then your statement in your macro will simply be:
rsAtt!ATTACHMENT_LINK = filename & "#" & filepath & filename
The hyperlink definition is important and uses the format:
displayString # fullPathToFile [ # optionalPositionInsideFile ]
EDIT: Using the Attachment Field Type in Access
The Attachment field type in an Access table can be understood if you consider it an embedded recordset within that single record. Therefore, every time you add a new record (or read an existing record), you have to handle the Attachment field a bit differently. In fact, the .Value of the Attachment field is the recordset itself.
Option Compare Database
Option Explicit
Sub test()
AddAttachment "C:\Temp\DepTree.txt"
End Sub
Sub AddAttachment(filename As String)
Dim tblAppointments As DAO.Recordset
Dim attachmentField As DAO.Recordset
Dim tblField As Field
Set tblAppointments = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT", dbOpenDynaset)
tblAppointments.AddNew
tblAppointments![APPT_ITEM_ID] = "new item id"
tblAppointments![APPT_FIELD_ID] = "new field id"
tblAppointments![ATTACHMENT_TITLE] = "new attachment"
tblAppointments![ATTACHMENT_FILENAME] = filename
'--- the attachment field itself is a recordset, because you can add multiple
' attachments to this single record. so connect to the recordset using the
' .Value of the parent record field, then use it like a recordset
Set attachmentField = tblAppointments![ATTACHMENT_BLOB].Value
attachmentField.AddNew
attachmentField.Fields("FileData").LoadFromFile filename
attachmentField.Update
tblAppointments.Update
tblAppointments.Close
Set tblAppointments = Nothing
End Sub
Here is what I ended up doing.
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
Call FileToBlob(filePath, rsAtt!ATTACHMENT_BLOB)
rsAttID = rsAtt!ID
rsAtt.Update
Next
End Function
Public Function FileToBlob(strFile As String, ByRef Field As Object)
On Error GoTo FileToBlobError
If Len(Dir(strFile)) > 0 Then
Dim nFileNum As Integer
Dim byteData() As Byte
nFileNum = FreeFile()
Open strFile For Binary Access Read As nFileNum
If LOF(nFileNum) > 0 Then
ReDim byteData(1 To LOF(nFileNum))
Get #nFileNum, , byteData
Field = byteData
End If
Else
MsgBox "Error: File not found", vbCritical, _
"Error reading file in FileToBlob"
End If
FileToBlobExit:
If nFileNum > 0 Then Close nFileNum
Exit Function
FileToBlobError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error reading file in FileToBlob"
Resume FileToBlobExit
End Function
I would like to create a program in Excel that loops through a list of Access databases and writes the VBA that exists in the Access modules. I have found some code that I can run from Access which writes the VBA that exists in the Access modules. I am trying to figure out how to reference the database files from Excel and run the program on each database file. I will probably be able to figure out how to loop through the database files. I just need help with referencing the database file in the below code.
I can open the database with something like this:
Dim cstrDbFile As String = "C:\Database51.accdb"
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
objShell.Run cstrDbFile
I also tried to set up a reference to Access like this:
Dim appAccess As Object
Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase ("C:\Database51.accdb")
I need to figure out how to refer to the Access database in:
Application.VBE.ActiveVBProject.VBComponents
I probably need to figure out how to create a reference to replace ActiveVBProject.
Below is some code I found which writes the contents of VBA modules. I don't remember where I found it.
For Each Component In Application.VBE.ActiveVBProject.VBComponents
With Component.CodeModule
'The Declarations
For Index = 1 To .CountOfDeclarationLines
Debug.Print .Lines(Index, 1)
Next Index
'The Procedures
For Index = .CountOfDeclarationLines + 1 To .CountOfLines
Debug.Print .Lines(Index, 1)
Next Index
End With
Next Component
The following code will let you see Access database objects, but I don't know how to export the code (DoCmd not in Excel?). Your task would be VERY simple to do from Access, so I would reconsider...
Option Explicit
' Add a reference to the DAO Object Library
Sub Read_Access_VBA()
Dim dbs As DAO.Database
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim iC As Integer
Dim iD As Integer
Dim i As Integer
Dim mdl As Module
Set dbs = DBEngine.OpenDatabase("c:\TEMP\106thRoster.mdb", False, False, _
"MS Access;")
Debug.Print "----------------------------------------"
For iC = 0 To dbs.Containers.Count - 1
Debug.Print "Container: " & dbs.Containers(iC).Name
If dbs.Containers(iC).Documents.Count > 0 Then
For iD = 0 To dbs.Containers(iC).Documents.Count - 1
Debug.Print vbTab & "Doc: " & dbs.Containers(iC).Documents(iD).Name
Next iD
Else
Debug.Print " No Documents..."
End If
Next iC
'Set ctr = dbs.Containers!Modules
dbs.Close
Set doc = Nothing
Set ctr = Nothing
Set dbs = Nothing
End Sub
I was able to find some code that will assist me with my final goal: Exporting MS Access Forms and Class / Modules Recursively to text files?
Below are the most significant lines that will allow me to make progress with the project.
LineCount = oApp.Forms(Name).Module.CountOfLines
FileName = Path & "\" & Name & ".vba"
F = FreeFile
Open FileName For Output Access Write As #F
Print #F, oApp.Forms(Name).Module.Lines(1, LineCount)
Close #F
I have a couple of mdb files with the exact table structure. I have to change the primary key of the main table from autonumber to number in all of them, which means I have to:
Drop the all the relationships the main table has
Change the main table
Create the relationships again,... for all the tables.
Is there any way to export the relationships from one file and importing them to all the rest?
I am sure this can be done with some macro/vb code. Does anyone has an example I could use?
Thanks.
Not a complete solution, but this may get you going...
The following function will print out the metadata for all relationships. Change this to save to a file in whatever format you prefer (CSV, tab delimited, XML, etc.):
Function PrintRelationships()
For Each rel In CurrentDb.Relations
With rel
Debug.Print "Name: " & .Name
Debug.Print "Attributes: " & .Attributes
Debug.Print "Table: " & .Table
Debug.Print "ForeignTable: " & .ForeignTable
Debug.Print "Fields:"
For Each fld In .Fields
Debug.Print "Field: " & fld.Name
Next
End With
Next
End Function
This function will drop all the relationships in the database:
Function DropRelationships()
With CurrentDb
For Each rel In .Relations
.Relations.Delete Name:=rel.Name
Next
End With
End Function
This function will create a relationship. You'll have to iterate over the file of saved relationship data.
Function CreateRelationships()
With CurrentDb
Set rel = .CreateRelation(Name:="[rel.Name]", Table:="[rel.Table]", ForeignTable:="[rel.FireignTable]", Attributes:=[rel.Attributes])
rel.Fields.Append rel.CreateField("[fld.Name for relation]")
rel.Fields("[fld.Name for relation]").ForeignName = "[fld.Name for relation]"
.Relations.Append rel
End With
End Function
Error handling and IO omitted due to time constraints (gotta put the kids to bed).
Hope this helps.
Based on #Patrick Cuff's answer, I have created a pair of scripts: one exporting into xml, other reading this xml and parsing it into the database
VBScript for exporting relationships from MsAccess into XML
'supply the Access Application object into this function and path to file to which the output should be written
Function ExportRelationships(oApplication, sExportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.appendChild relDoc.createElement("Relations") 'create root xml element
'loop though all the relations
For Each myObj In oApplication.CurrentDb.Relations
If Not Left(myObj.Name, 4) = "MSys" Then 'exclude system relations
Dim relName, relAttrib, relTable, relFoTable, fld
relDoc.childNodes(0).appendChild relDoc.createElement("Relation")
Set relName = relDoc.createElement("Name")
relName.Text = myObj.Name
relDoc.childNodes(0).lastChild.appendChild relName
Set relAttrib = relDoc.createElement("Attributes")
relAttrib.Text = myObj.Attributes
relDoc.childNodes(0).lastChild.appendChild relAttrib
Set relTable = relDoc.createElement("Table")
relTable.Text = myObj.Table
relDoc.childNodes(0).lastChild.appendChild relTable
Set relFoTable = relDoc.createElement("ForeignTable")
relFoTable.Text = myObj.ForeignTable
relDoc.childNodes(0).lastChild.appendChild relFoTable
'in case the relationship works with more fields
For Each fld In myObj.Fields
Dim lf, ff
relDoc.childNodes(0).lastChild.appendChild relDoc.createElement("Field")
Set lf = relDoc.createElement("Name")
lf.Text = fld.Name
relDoc.childNodes(0).lastChild.lastChild.appendChild lf
Set ff = relDoc.createElement("ForeignName")
ff.Text = fld.ForeignName
relDoc.childNodes(0).lastChild.lastChild.appendChild ff
Next
End If
Next
relDoc.insertBefore relDoc.createProcessingInstruction("xml","version='1.0'"), relDoc.childNodes(0)
relDoc.Save sExportpath
End Function
VBScript for importing relationships into MsAccess from XML
'supply the Access Application object into this function and path to file from which the input should be read
Function ImportRelationships(oApplication, sImportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.Load(sImportpath)
Dim xmlRel, xmlField, accessRel, relTable, relName, relFTable, relAttr, i
'loop through every Relation node inside .xml file
For Each xmlRel in relDoc.selectNodes("/Relations/Relation")
relName = xmlRel.selectSingleNode("Name").Text
relTable = xmlRel.selectSingleNode("Table").Text
relFTable = xmlRel.selectSingleNode("ForeignTable").Text
relAttr = xmlRel.selectSingleNode("Attributes").Text
'remove any possible conflicting relations or indexes
On Error Resume next
oApplication.CurrentDb.Relations.Delete (relName)
oApplication.CurrentDb.TableDefs(relTable).Indexes.Delete(relName)
oApplication.CurrentDb.TableDefs(relFTable).Indexes.Delete(relName)
On Error Goto 0
'create the relationship object
Set accessRel = oApplication.CurrentDb.CreateRelation(relName, relTable, relFTable, relAttr)
'in case the relationship works with more fields
For Each xmlField In xmlRel.selectNodes("Field")
accessRel.Fields.Append accessRel.CreateField(xmlField.selectSingleNode("Name").Text)
accessRel.Fields(xmlField.selectSingleNode("Name").Text).ForeignName = xmlField.selectSingleNode("ForeignName").Text
Next
'and finally append the newly created relationship to the database
oApplication.CurrentDb.Relations.Append accessRel
Next
End Function
Notes
Just to clarify what is expected to be passed into oApplication parameter
Set oApplication = CreateObject("Access.Application")
oApplication.NewCurrentDatabase path 'new database
oApplication.OpenCurrentDatabase path 'existing database
In case you are running this from VBA instead of VBScript, you can delete the parameter and just the regular Application object everywhere in the code where oApplication is being used.
I got started to work on this code as I needed to implement a Version Control on a very complicated MsAccess project. This post got me moving, there are also some good advices on how to export/import other parts of the MsAccess project.
It occurs to me that you can use a backup of the file made before any changes to restore the indexes and relations. Here are some notes.
Sub RunExamples()
Dim strCopyMDB As String
Dim fs As FileSystemObject
Dim blnFound As Boolean
Dim i
' This code is not intended for general users, it is sample code built '
' around the OP '
'You will need a reference to the Microsoft DAO 3.x Object Library '
'This line causes an error, but it will run '
'It is not suitable for anything other than saving a little time '
'when setting up a new database '
Application.References.AddFromFile ("C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll")
'You must first create a back-up copy '
Set fs = CreateObject("Scripting.FileSystemObject")
strCopyMDB = CurrentProject.Path & "\c.mdb"
blnFound = fs.FileExists(strCopyMDB)
i = 0
Do While blnFound
strCopyMDB = CurrentProject.Path & "\c" & i & ".mdb"
blnFound = fs.FileExists(strCopyMDB)
Loop
fs.CopyFile CurrentProject.FullName, strCopyMDB
ChangeTables
AddIndexesFromBU strCopyMDB
AddRelationsFromBU strCopyMDB
End Sub
Sub ChangeTables()
Dim db As Database
Dim tdf As DAO.TableDef
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim ndx As DAO.Index
Dim i
Set db = CurrentDb
'In order to programmatically change an autonumber, '
'it is necessary to delete any relationships that '
'depend on it. '
'When deleting from a collection, it is best '
'to iterate backwards. '
For i = db.Relations.Count - 1 To 0 Step -1
db.Relations.Delete db.Relations(i).Name
Next
'The indexes must also be deleted or the '
'number cannot be changed. '
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "Msys" Then
For i = tdf.Indexes.Count - 1 To 0 Step -1
tdf.Indexes.Delete tdf.Indexes(i).Name
Next
tdf.Indexes.Refresh
For Each fld In tdf.Fields
'If the field is an autonumber, '
'use code supplied by MS to change the type '
If (fld.Attributes And dbAutoIncrField) Then
AlterFieldType tdf.Name, fld.Name, "Long"
End If
Next
End If
Next
End Sub
Sub AddIndexesFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim tdf As DAO.TableDef
Dim tdfBU As DAO.TableDef
Dim ndx As DAO.Index
Dim ndxBU As DAO.Index
Dim i
Set db = CurrentDb
'This is the back-up made before starting '
Set dbBU = OpenDatabase(MDBBU)
For Each tdfBU In dbBU.TableDefs
'Skip system tables '
If Left(tdfBU.Name, 4) <> "Msys" Then
For i = tdfBU.Indexes.Count - 1 To 0 Step -1
'Get each index from the back-up '
Set ndxBU = tdfBU.Indexes(i)
Set tdf = db.TableDefs(tdfBU.Name)
Set ndx = tdf.CreateIndex(ndxBU.Name)
ndx.Fields = ndxBU.Fields
ndx.IgnoreNulls = ndxBU.IgnoreNulls
ndx.Primary = ndxBU.Primary
ndx.Required = ndxBU.Required
ndx.Unique = ndxBU.Unique
' and add it to the current db '
tdf.Indexes.Append ndx
Next
tdf.Indexes.Refresh
End If
Next
End Sub
Sub AddRelationsFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim relBU As DAO.Relation
Dim i, j, f
On Error GoTo ErrTrap
Set db = CurrentDb
'The back-up again '
Set dbBU = OpenDatabase(MDBBU)
For i = dbBU.Relations.Count - 1 To 0 Step -1
'Get each relationship from bu '
Set relBU = dbBU.Relations(i)
Debug.Print relBU.Name
Set rel = db.CreateRelation(relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes)
For j = 0 To relBU.Fields.Count - 1
f = relBU.Fields(j).Name
rel.Fields.Append rel.CreateField(f)
rel.Fields(f).ForeignName = relBU.Fields(j).ForeignName
Next
'For some relationships, I am getting error'
'3284 Index already exists, which I will try'
'and track down tomorrow, I hope'
'EDIT: Apparently this is due to Access creating hidden indexes
'and tracking these down would take quite a bit of effort
'more information can be found in this link:
'http://groups.google.ie/group/microsoft.public.access/browse_thread/thread/ca58ce291bdc62df?hl=en&ie=UTF-8&q=create+relation+3284+Index+already+exists
'It is an occasional problem, so I've added an error trap
'Add the relationship to the current db'
db.Relations.Append rel
Next
ExitHere:
Exit Sub
ErrTrap:
If Err.Number = 3284 Then
Debug.Print relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes
Resume Next
Else
'this is not a user sub, so may as well ... '
Stop
End If
End Sub
Sub AlterFieldType(TblName As String, FieldName As String, _
NewDataType As String)
'http://support.microsoft.com/kb/128016'
Dim db As Database
Dim qdf As QueryDef
Set db = CurrentDb()
' Create a dummy QueryDef object.'
Set qdf = db.CreateQueryDef("", "Select * from PROD1")
' Add a temporary field to the table.'
qdf.SQL = "ALTER TABLE [" & TblName & "] ADD COLUMN AlterTempField " & NewDataType
qdf.Execute
' Copy the data from old field into the new field.'
qdf.SQL = "UPDATE DISTINCTROW [" & TblName _
& "] SET AlterTempField = [" & FieldName & "]"
qdf.Execute
' Delete the old field.'
qdf.SQL = "ALTER TABLE [" & TblName & "] DROP COLUMN [" _
& FieldName & "]"
qdf.Execute
' Rename the temporary field to the old field's name.'
db.TableDefs("[" & TblName & "]").Fields("AlterTempField").Name = FieldName
End Sub
Thanks for code snippet.
to get rid of your 3284 error I have changed a few things.
If you copy all indexes from sample mdb and then try to put relationships it throws an exception as it expects no idexes for relationshisps when you put relationships it puts its own indexes.
Steps I followed are (assume target.mdb and source.mdb):
Run this code in target.mdb remove all indexes and relationsships
frmo target.mdb by calling ChangeTables
Call AddIndexesFromBU source.mdb and use condition
If ndxBU.Unique Then tdf.Indexes.Append ndx End If this willput just Unique index
call AddRelationsFromBU source.mdb and put all relationsships
Call again AddIndexesFromBU source.mdb and change condition to If
not ndxBU.Unique Then
I have also added error trap same as AddRelationsFromBU in AddIndexesFromBU and resume next for if ans else
This worked for me.