Opening another Access Database

[Tom McNally]

Am using XP Access 10 and frequently need to update remote users with
updates to a live database. In the past (Access97 and Access 2000) I used
the OpenDatabase method in a function call to copy updated forms, queries,
tables etc. to the live database. In XP this blows.. Below is my function
call. Perhaps someone can point out my error...

Thanks,

Tom

'************************************
Function UpdateDatabase() As Boolean
On Error GoTo UpdateDatabase_Error

Dim wksMain As DAO.Workspace
Dim sDatabaseName As String
Dim dbsThisDatabase As DAO.Database
Dim sObjectName As String
Dim sObjectType As String
Dim iCount As Integer
Dim ctl As Control
Dim rst As DAO.Recordset
Dim rel As DAO.Relation
Dim strRelation As String
Dim fld As Field

Set wksMain = DBEngine.Workspaces(0)
Set ctl = Me.Controls("txtUpdating")
ctl.Visible = True
ctl.SetFocus

Set dbsThisDatabase = wksMain.OpenDatabase(CurrentDb.Name)
Set rst = dbsThisDatabase.OpenRecordset("tblDatabase", dbOpenDynaset)
DoCmd.SetWarnings False

With rst
.MoveFirst
'this field specifies the database location on the network
sDatabaseName = .Fields(0)
End With

'checks to see if File exists otherwise prompts user
If fIsFileDIR(sDatabaseName) = False Then
MsgBox sDatabaseName & " cannot be found!" & Chr(13) _
& "Please Try again by double-clicking on the Plain White Box ",
vbOKOnly
UpdateDatabase = False
ctl.Visible = False
Else
'Check if they exist and delete and then copy Updates
' Set dbsToUpdate = wksMain.OpenDatabase(sDatabaseName)
Set objAcc = New Access.Application
ctl.Value = "Updating: " & sDatabaseName
With objAcc
.Visible = False
.OpenCurrentDatabase sDatabaseName, False


'******* Tables *********
sObjectName = "tblAppProp"
sObjectType = "Table"
If ObjectExists(sObjectType, sObjectName, sDatabaseName) Then
.DoCmd.DeleteObject acTable, sObjectName
End If
ctl.Value = "Updating " & sObjectType & ": " & sObjectName
DoCmd.CopyObject sDatabaseName, , acTable, sObjectName


'******* Queries *********
sObjectName = "qryReNewOrganization-AppendJV-2"
sObjectType = "Query"
If ObjectExists(sObjectType, sObjectName, sDatabaseName) Then
.DoCmd.DeleteObject acQuery, sObjectName
End If
ctl.Value = "Updating " & sObjectType & ": " & sObjectName
DoCmd.CopyObject sDatabaseName, , acQuery, sObjectName


'******* Forms *********
sObjectName = "frmEvaluation Director Change Form"
sObjectType = "Form"
If ObjectExists(sObjectType, sObjectName, sDatabaseName) Then
.DoCmd.DeleteObject acForm, sObjectName
End If
ctl.Value = "Updating " & sObjectType & ": " & sObjectName
DoCmd.CopyObject sDatabaseName, , acForm, sObjectName


'******* Reports *********
sObjectName = "Perf Eval Directors MidTerm Report"
sObjectType = "Report"
If ObjectExists(sObjectType, sObjectName, sDatabaseName) Then
.DoCmd.DeleteObject acReport, sObjectName
End If
ctl.Value = "Updating " & sObjectType & ": " & sObjectName
DoCmd.CopyObject sDatabaseName, , acReport, sObjectName


'********* Macros **********
sObjectName = "Run Update on Ranking and Employees New"
sObjectType = "Macro"
If ObjectExists(sObjectType, sObjectName, sDatabaseName) Then
.DoCmd.DeleteObject acMacro, sObjectName
End If
ctl.Value = "Updating " & sObjectType & ": " & sObjectName
DoCmd.CopyObject sDatabaseName, , acMacro, sObjectName

.CloseCurrentDatabase
.Quit

End With
ctl.Value = "Update -" + strUpdateVersion + "- Completed!"
Sleep 2000
beep
Me.txtDatabase.SetFocus
ctl.Visible = False
UpdateDatabase = True
End If

DoCmd.SetWarnings True


UpdateDatabase_Exit:
Set rst = Nothing
Set dbsThisDatabase = Nothing
Set wksMain = Nothing
Set objAcc = Nothing
Exit Function

UpdateDatabase_Error:
Select Case Err.Number

Case Else
MsgBox "Unexpected Error!" & vbCr & vbCr & Error$, vbCritical,
"Error in UpdateDatabase"
Me.txtDatabase.SetFocus
objAcc.CloseCurrentDatabase
objAcc.Quit
ctl.Visible = False
Resume UpdateDatabase_Exit

End Select

End Function


' Pass the Object type: Table, Query, Form, Report, Macro, or Module
' Pass the Object Name
Function ObjectExists(strObjectType As String, strObjectName As String,
strTargetDatabase As String) As Boolean

On Error GoTo ObjectExists_Error

Dim wks As Workspace
Dim db As Database
Dim tbl As TableDef
Dim qry As QueryDef
Dim i As Integer

Set wks = DBEngine.Workspaces(0)
Set db = wks.OpenDatabase(strTargetDatabase)
ObjectExists = False

If strObjectType = "Table" Then
For Each tbl In db.TableDefs
If tbl.Name = strObjectName Then
ObjectExists = True
Exit Function
End If
Next tbl
ElseIf strObjectType = "Query" Then
For Each qry In db.QueryDefs
If qry.Name = strObjectName Then
ObjectExists = True
Exit Function
End If
Next qry
ElseIf strObjectType = "Form" Then
For i = 0 To db.Containers(strObjectType & "s").Documents.Count - 1
If db.Containers(strObjectType & "s").Documents(i).Name =
strObjectName Then
ObjectExists = True
Exit Function
End If
Next i
ElseIf strObjectType = "Report" Then
For i = 0 To db.Containers(strObjectType & "s").Documents.Count - 1
If db.Containers(strObjectType & "s").Documents(i).Name =
strObjectName Then
ObjectExists = True
Exit Function
End If
Next i
ElseIf strObjectType = "Module" Then
For i = 0 To db.Containers(strObjectType & "s").Documents.Count - 1
If db.Containers(strObjectType & "s").Documents(i).Name =
strObjectName Then
ObjectExists = True
Exit Function
End If
Next i
ElseIf strObjectType = "Macro" Then
For i = 0 To db.Containers("Scripts").Documents.Count - 1
If db.Containers("Scripts").Documents(i).Name = strObjectName
Then
ObjectExists = True
Exit Function
End If
Next i
Else
MsgBox "Invalid Object Type passed, must be Table, Query, Form,
Report, Macro, or Module"
End If

Set db = Nothing
Set wks = Nothing

ObjectExists_Exit:
Exit Function

ObjectExists_Error:
Select Case Err.Number

Case Else
MsgBox "Unexpected Error!" & vbCr & vbCr & Error$, vbCritical,
"Updates For Database in ObjectExists"
Resume ObjectExists_Exit

End Select

End Function

 

[Tom McNally]

Never mind about this one.. saw my error -- forgot to preface the objects
with the DAO reference keyword.... Oh well.