Running Access From Excel 1

[UnsolvedCoding]

Hey all -

I solved all my problems for running Access from Excel except for one. It won't release the database after running the macro unless I close Excel and re-open it.

Anyone know how to actually close Access so it releases instead of needing to shut down Excel?

Heres the code


Sub Open_MDB()

Dim obj1 As AccessObject
Dim appAccess1
Dim strPath As String
Dim strFile As String
Dim strDBName As String

'Create a reference to another database file
Set appAccess1 = New Access.Application
strPath = "C:\Desktop\MDB.Folder\"
strFile = "Data_Import.mdb"
strDBName = strPath & strFile
appAccess1.OpenCurrentDatabase strDBName

' Run the macro
CheckAndCorrectColumns

' Close objects
appAccess1.CloseCurrentDatabase

appAccess1.Quit

Set appAccess1 = Nothing

End Sub

 

[PHV]

What is the code of CheckAndCorrectColumns ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[UnsolvedCoding]

That is a rather lengthy macro that involves a handful of functions which only has the purpose of making sure that the correct headers are in place in a specific Access table.

 

[judgeh59]

just a thought

' Close objects
appAccess1.CloseCurrentDatabase

appAccess1.Quit

Set appAccess1 = Nothing


Maybe

appAccess1.CloseCurrentDatabase
Set appAccess1 = Nothing
appAccess1.Quit

Hope this helps...

Ernest

Be Alert, America needs more lerts

 

[PHV]

That is a rather lengthy macro
So, be sure that all access objects are fully qualified otherwise you get ghosts msaccess.exe instances ...

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Gammachaser]

Try using

appAccess1.Visible = True

to show the access application and watch what happens. My bet is that you are modifying the table and when you close it Access is waiting for a reply to 'Do you want to save changes to the design of 'thistable'?

Alternately, some error may be occurring and Access is waiting for a reply to the error notification. Either way, making the application visible may help spot the problem. When the problem is solved, remove the added code so the routine will run faster.

 

[UnsolvedCoding]

Gammachaser, I will try what you suggest and see whats happening.

Here is the short version of the macro. I have to warn you, this project was written by someone who just left the company and was given to me to clean up and I haven't finished yet. This code does work to do what we want but it won't release Access if run from Excel, and if run directly in Access will run properly.
This is the piece that is being rebuilt now.

All variables and functions are declared as public in a sperate location.

Functions are included below.


Sub CheckAndCorrectColumns()


'initialize sMsg
sMsg = ""
sMsg = InputBox("Please enter last part of table." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"Claim_", "Claim Information", "End of Claim")

If sMsg = Empty Then
MsgBox "Cancel pressed or last part of claim number missing"
Warning_Flag = 1
Exit Sub
End If

tableName = "Claims_" & sMsg

'' Print the info in the immediate window if desired
'Debug.Print tableName

'Clear variable
sMsg = ""


If TableExists(tableName) Then

'for R type only
If InStr(1, tableName, "Claims_R") > 0 Then
columnNameNew = "CHGBKNUM" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If

End If


If InStr(1, tableName, "Claims_M") > 0 Then
columnNameOld1 = "INVC-I" 'hardcode
columnNameOld2 = "INV_NBR" 'hardcode
columnNameNew = "INVOICE_NB" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld1) Then
Call RenameColumn(tableName, columnNameOld1, columnNameNew)
ElseIf FieldExists(tableName, columnNameOld2) Then
Call RenameColumn(tableName, columnNameOld2, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If

columnNameOld = "COST-A" 'hardcode
columnNameNew = "COST" 'hardcode

columnNameNew = "COST" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
End If

'for non-R, non-M types
If Not InStr(1, tableName, "Claims_R") > 0 And Not InStr(1, tableName, "Claims_M") > 0 Then
columnNameNew = "FMT_PRO" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameOld = "MBILL_ID" 'hardcode
columnNameNew = "MBILL_ID_A" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
End If
'for all types
columnNameNew = "CLASS" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "CLAIM_AMT" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "CLAIM_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "DELETE" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "DEPTNBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "DETAIL_AMT" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "DETAIL_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "SCAC" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameOld = "STORE" 'hardcode
columnNameNew = "STRNBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
columnNameNew = "VND_NAME" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameOld1 = "VND_NBB" 'hardcode
columnNameOld2 = "VEN_NBR" 'hardcode
columnNameNew = "VND_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld1) Then
Call RenameColumn(tableName, columnNameOld1, columnNameNew)
ElseIf FieldExists(tableName, columnNameOld2) Then
Call RenameColumn(tableName, columnNameOld2, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
columnNameNew = "BILLTO" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "F_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameNew = "P_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
columnNameOld = "SHIP_DATE" 'hardcode
columnNameNew = "P_DTE" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
columnNameOld = "FLOW_I" 'hardcode
columnNameNew = "FLOW" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
columnNameOld = "CHKNBR" 'hardcode
columnNameNew = "CHECK_NBR" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If
columnNameOld = "CHKDT" 'hardcode
columnNameNew = "CHECK_DATE" 'hardcode
If Not FieldExists(tableName, columnNameNew) Then
If FieldExists(tableName, columnNameOld) Then
Call RenameColumn(tableName, columnNameOld, columnNameNew)
Else
sMsg = sMsg & columnNameNew & " not found" & vbCrLf
End If
End If

If sMsg > "" Then
MsgBox sMsg
Else
MsgBox "Done. No missing Columns"
End If

Else 'table not exists
MsgBox "Table " & tableName & " not exists"
End If

End Sub

Public Function TableExists(tblName As String) As Boolean

' Dim tbl As TableDef
' Dim sName As String

On Error GoTo Failed

If Len(CurrentDb.TableDefs(tblName).Name) > 0 Then
TableExists = True
Exit Function
End If

Failed:
If Err.Number = 3265 Then Err.Clear 'Error 3265 : Item not found in this collection.
TableExists = False

End Function


Public Function FieldExists(tblName As String, colName As String) As Boolean

' Dim tbl As TableDef
' Dim fld As Field
' Dim sName As String
On Error GoTo Failed

If Len(CurrentDb.TableDefs(tblName).Fields(colName).Name) > 0 Then
FieldExists = True
Exit Function
End If

Failed:
If Err.Number = 3265 Then Err.Clear 'Error 3265 : Item not found in this collection.
FieldExists = False

End Function

Public Function RenameColumn(tableName As String, oldColName As String, newColName As String)

' Dim db As Database
' Dim td As TableDef
' Dim fld As Field

Set db = CurrentDb
Set td = db.TableDefs(tableName)

For Each fld In td.Fields
If fld.Name = oldColName Then
fld.Name = newColName
Exit For
End If
Next fld

db.TableDefs.Refresh

Set td = Nothing
Set db = Nothing

End Function

 

[PHV]

Well, as I suspected, your code use NOT fully qualified access objects, eg:
If Len(CurrentDb.TableDefs(tblName).Name) > 0 Then
instead of:
If Len(appAccess1.CurrentDb.TableDefs(tblName).Name) > 0 Then

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[UnsolvedCoding]

PHV,

I changed it as you suggested and moved the Docmd for closing the table and the database and it works.

Thanks.