'~~~~~------------------------------------------------------------------------
' MODULE: Attach Table Lib
' AUTHOR: Curtis Consulting Group
' DATE: 08/02/1993
' PURPOSE: To Attach and Detach Tables
' DESCRIPTION: Uses Tables: TableDef and TableAttach
' Uses Queries: qryTablesToAttach, qryDBsToAttach
' Uses Modules: MailLib (Send mail if corrupt)
' Uses APP_NAME constant for msgboxes
'
' MODIFICATIONS (MOST RECENT ON TOP)
'DATE -Function-INI-CHANGE
'04/11/94 DetachTable-djs-rewrote
'03/xx/94 AttachAllTables and AttachTable-kdh-mod for SQL Server
'01/20/94 Verifile-djs-moved from StdLib module
'01/20/94 AttachAllTables-simplified error message
'12/07/93 AttachAllTables-elm-add drive/path/file to error message
'12/02/93 AttachAllTables-djs-prompt user for path if DrivePathFile is blank
'11/02/93 AttachAllTables-djs-test opening each db - requires qryDBsToAttach and new field in TableAttach
'------------------------------------------------------------------------+++++
Option Compare Database 'Use database order for string comparisons
Option Explicit
Dim dum
'''''-------------------------------------------------------------------------
' TITLE: Attach All Tables
' AUTHOR: D.J. Schuba
' DATE: 08/02/1993
' PURPOSE: To attach all tables according to TableDef and TableAttach
' DESCRIPTION:
'
'------------------------------------------------------------------------+++++
Function AttachAllTables() As Integer
Dim db As Database, dbTest As Database, ds As Recordset
Dim DrivePathFile$, DrivePath$, TableName$, LastAttach$, Notify$
Dim retval%, SourceType$
Dim TblCnt
DoCmd.Hourglass True
retval = True
' Test open all databases
On Error GoTo CannotOpenDB
Set db = CurrentDb()
Set ds = db.OpenRecordset("qryDBsToAttach")
If Not ds.EOF Then
Do Until ds.EOF
If IsNull(ds!DrivePathFile) Then
' Need to ask user where the data is
Do
If Len(DrivePath) = 0 Then
DrivePath = InputBox$("Enter the drive\path for " & ds!DfltFile & ". Please use the universal naming convention for network drives (e.g., \\serverx\sharey ).", App_Name)
End If
If Len(DrivePath) = 0 Then
' the user did not even try so quit
DoCmd.Quit
Else
If Right(DrivePath, 1) = "\" Then
DrivePathFile = DrivePath & ds!DfltFile
Else
DrivePathFile = DrivePath & "\" & ds!DfltFile
End If
Set dbTest = OpenDatabase(DrivePathFile)
If Len(DrivePath) Then
ds.Edit
ds!DrivePathFile = DrivePathFile
ds.Update
End If
End If
Loop Until Len(DrivePath)
Else
' test open for corruption only for MS Access Tables
If ds!SourceType = "MSACCESS" Then
Set dbTest = OpenDatabase(ds!DrivePathFile)
End If
End If
ds.MoveNext
Loop
End If
ds.Close
' Now let's see if everything is attached correctly
On Error GoTo 0
Set ds = db.OpenRecordset("qryTablesToAttach")
If Not ds.EOF Then
ds.MoveLast
TblCnt = ds.RecordCount
dum = SysCmd(1, "Attaching Tables...", TblCnt)
TblCnt = 0
ds.MoveFirst
Do Until ds.EOF
TableName = IIf(IsNull(ds!NameOfTable), "", ds!NameOfTable)
DrivePathFile = IIf(IsNull(ds!DrivePathFile), "", ds!DrivePathFile)
LastAttach = IIf(IsNull(ds!LastAttach), "", ds!LastAttach)
SourceType = IIf(IsNull(ds!SourceType), "", ds!SourceType)
If DrivePathFile <> LastAttach Then
If Not AttachTable(DrivePathFile, SourceType, TableName) Then GoTo Error_AttachAllTables
ds.Edit
ds!LastAttach = DrivePathFile
ds.Update
End If
TblCnt = TblCnt + 1
dum = SysCmd(2, TblCnt)
ds.MoveNext
Loop
End If
Exit_AttachAllTables:
On Error Resume Next
ds.Close
db.Close
DoCmd.Hourglass False
dum = SysCmd(3) 'shutdown status bar
AttachAllTables = retval
Exit Function
Error_AttachAllTables:
MsgBox "Failed to attach " & TableName & " in " & DrivePathFile & ".", w_MB_ICONSTOP, "Attach Failed"
retval = False
GoTo Exit_AttachAllTables
CannotOpenDB:
Select Case Err
Case 3049
' Corrupt file - fatal error!
MsgBox App_Name & " needs to be repaired. Please try " & App_Name & " again later.", w_MB_ICONSTOP, "Open Database Failed"
Notify = CNull(ds!IfCorruptNotify, "")
'dum = SendMail(ds!DrivePathFile & " is corrupt and needs to be repaired.", Notify, "", "", "", "")
DoCmd.Quit
Case Else
MsgBox Error$, w_MB_ICONINFORMATION, App_Name
DrivePath = ""
Resume Next
End Select
Exit Function
End Function
'''''-------------------------------------------------------------------------
' TITLE: Attach Table
' AUTHOR: Bob Hamilton
' DATE: mm/dd/1993
' PURPOSE: To Attach a table
' DESCRIPTION:
'
'------------------------------------------------------------------------+++++
Function AttachTable(DBName$, SourceType$, TableName$) As Integer
Dim retval%
retval = False ' assume failure
On Error GoTo Exit_AttachTable
dum = DetachTable(TableName)
' don't care if no detach because it may not have been attached
Select Case SourceType
Case "MSACCESS"
DoCmd.TransferDatabase A_ATTACH, "Microsoft Access", DBName, A_TABLE, TableName, TableName, False
retval = True ' success
Case "SQLSERVER"
DoCmd.TransferDatabase A_ATTACH, "<SQL Database>", "ODBC;DSN=;UID=WhoRyou;;APP=Microsoft Access;DATABASE=" & DBName, A_TABLE, "dbo." & TableName, TableName
retval = True ' success
Case Else
retval = False
End Select
Exit_AttachTable:
AttachTable = retval
Exit Function
End Function
'''''-------------------------------------------------------------------------
' TITLE: Detach All Tables
' AUTHOR: Bob Hamilton
' DATE: mm/dd/1993
' PURPOSE: Detaches all attached tables
' DESCRIPTION:
'
'------------------------------------------------------------------------+++++
Function DetachAllTables() As Integer
Dim db As Database
Dim ss As Snapshot
Set db = CurrentDb()
Set ss = db.ListTables()
ss.MoveFirst
Do While Not ss.EOF
If (ss!TableType = DB_ATTACHEDTABLE Or ss!TableType = DB_ATTACHEDODBC) And Left$(ss!Name, 4) <> "~TMP" Then
DoCmd.SelectObject A_TABLE, ss!Name, True
DoCmd.SetWarnings False
' domenuitem Database, Edit, Delete
DoCmd.DoMenuItem 1, 1, 4
DoCmd.SetWarnings True
End If
ss.MoveNext
Loop
DetachAllTables = True
End Function
'''''-------------------------------------------------------------------------
' TITLE: Detach Table
' AUTHOR: Dave Schuba
' DATE: 04/11/1994
' PURPOSE: Detach a table
' DESCRIPTION:
'------------------------------------------------------------------------+++++
Function DetachTable(TableName$) As Integer
Dim retval%
On Error GoTo Exit_DetachTable
retval = True
DoCmd.SelectObject A_TABLE, TableName, True
DoCmd.SetWarnings False
DoCmd.DoMenuItem 1, 1, 4 ' Database, Edit, Delete
DoCmd.SetWarnings True
Exit_DetachTable:
DetachTable = retval
Exit Function
End Function
'''''-------------------------------------------------------------------------
' TITLE: Get Database spec
' AUTHOR: djs
' DATE: 07/29/1993
' PURPOSE: Get spec from TableAttach
' DESCRIPTION: TableAttach should always be local
'------------------------------------------------------------------------+++++
Function GetDataBase(vId) As String
Dim db As Database
Dim tb As Table
Set db = CurrentDb()
Set tb = db.OpenTable("TableAttach")
tb.Index = "PrimaryKey"
tb.Seek "=", vId
If tb.NoMatch Then
GetDataBase = ""
Else
GetDataBase = IIf(IsNothing(tb!DrivePathFile), "", tb!DrivePathFile)
End If
tb.Close
db.Close
End Function
'''''-------------------------------------------------------------------------
' TITLE: Verifile
' AUTHOR: djs
' DATE: 06/24/1993
' PURPOSE: To verify that Key exists in Tablename
' DESCRIPTION: CANNOT HANDLE MULTIPLE PART KEYS
' CAN ONLY BE USED ON JET TABLES
' Same Usage: Exists% = Verifile(0,"Customer",100)
'------------------------------------------------------------------------+++++
Function Verifile(iTableAttachId As Integer, sTablename As String, vKey) As Integer
Dim db As Database
Dim tb As Table
Dim iRet
Dim sDBname As String
iRet = True
If IsNull(vKey) Then
' it won't be in the table if it is nothing
iRet = False
Else
sDBname = GetDataBase(iTableAttachId)
If Len(sDBname) And iTableAttachId > 0 Then
Set db = OpenDatabase(sDBname)
Else
Set db = CurrentDb()
End If
Set tb = db.OpenTable(sTablename)
tb.Index = "PrimaryKey"
tb.Seek "=", vKey
If tb.NoMatch Then
iRet = False
End If
tb.Close
db.Close
End If
Verifile = iRet
End Function
Comment