MDE doesn't like module (can't be created)

A

Andreas

Hello Newsgroup,

I got this wonderful code (below) from the internet to refresh links
to a front end database. It in one module in my mdb.

Its works perfect BUT I can't create a mde-file with this module in
the mde file (without it is no problem).
Description: "Microsoft Office Access was unable to create an MDE
database."

Does anybody knows what the problem is? (I altered the code slightly
in the beginning: 'Andi..., but this shouldn't be a problem I think).

Thank you very much for your help!

Andreas


'***************** Code Start ***************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Function fRefreshLinks() As Boolean
Dim strMsg As String, collTbls As Collection
Dim i As Integer, strDBPath As String, strTbl As String
Dim dbCurr As Database, dbLink As Database
Dim tdfLocal As TableDef
Dim varRet As Variant
Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000

On Local Error GoTo fRefreshLinks_Err

'Andi: I dont want this message
' If MsgBox("Are you sure you want to reconnect all Access
tables?", _
vbQuestion + vbYesNo, "Please confirm...") = vbNo Then
Err.Raise cERR_USERCANCEL

'First get all linked tables in a collection
Set collTbls = fGetLinkedTables

'now link all of them
Set dbCurr = CurrentDb

'Andi: Code original replace to link to path of frontend
' strMsg = "Do you wish to specify a different path for the Access
Tables?"
'
' If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data
source...") = vbYes Then
' strNewPath = fGetMDBName("Please select a new datasource")
' Else
' strNewPath = vbNullString
' End If
' *****End relink

'Andi: replaced with this code
strNewPath = Left(dbCurr.Name, Len(dbCurr.Name) -
Len(Dir(dbCurr.Name))) & _
"SP_Mali_be.mdb"
'Andi:end

For i = collTbls.Count To 1 Step -1
strDBPath = fParsePath(collTbls(i))
strTbl = fParseTable(collTbls(i))
varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl &
"'....")
If Left$(strDBPath, 4) = "ODBC" Then
'ODBC Tables
'ODBC Tables handled separately
' Set tdfLocal = dbCurr.TableDefs(strTbl)
' With tdfLocal
' .Connect = pcCONNECT
' .RefreshLink
' collTbls.Remove (strTbl)
' End With
Else
If strNewPath <> vbNullString Then
'Try this first
strDBPath = strNewPath
Else
If Len(Dir(strDBPath)) = 0 Then
'File Doesn't Exist, call GetOpenFileName
strDBPath = fGetMDBName("'" & strDBPath & "' not
found.")
If strDBPath = vbNullString Then
'user pressed cancel
Err.Raise cERR_USERCANCEL
End If
End If
End If

'backend database exists
'putting it here since we could have
'tables from multiple sources
Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

'check to see if the table is present in dbLink
strTbl = fParseTable(collTbls(i))
If fIsRemoteTable(dbLink, strTbl) Then
'everything's ok, reconnect
Set tdfLocal = dbCurr.TableDefs(strTbl)
With tdfLocal
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Else
Err.Raise cERR_NOREMOTETABLE
End If
End If
Next
fRefreshLinks = True
varRet = SysCmd(acSysCmdClearStatus)

'andi: I dont want this message
'MsgBox "All Access tables were successfully reconnected.", _
vbInformation + vbOKOnly, _
"Success"

fRefreshLinks_End:
Set collTbls = Nothing
Set tdfLocal = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
fRefreshLinks = False
Select Case Err
Case 3059:

Case cERR_USERCANCEL:
MsgBox "No Database was specified, couldn't link tables.",
_
vbCritical + vbOKOnly, _
"Error in refreshing links."
Resume fRefreshLinks_End
Case cERR_NOREMOTETABLE:
MsgBox "Table '" & strTbl & "' was not found in the
database" & _
vbCrLf & dbLink.Name & ". Couldn't refresh links",
_
vbCritical + vbOKOnly, _
"Error in refreshing links."
Resume fRefreshLinks_End
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description &
vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) &
vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical, "Error"
Resume fRefreshLinks_End
End Select
End Function

Function fIsRemoteTable(dbRemote As Database, strTbl As String) As
Boolean
Dim tdf As TableDef
On Error Resume Next
Set tdf = dbRemote.TableDefs(strTbl)
fIsRemoteTable = (Err = 0)
Set tdf = Nothing
End Function

Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String

strFilter = ahtAddFilterItem(strFilter, _
"Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
"*.mdb; *.mda; *.mde; *.mdw")
strFilter = ahtAddFilterItem(strFilter, _
"All Files (*.*)", _
"*.*")

fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
OpenFile:=True, _
DialogTitle:=strIn, _
Flags:=ahtOFN_HIDEREADONLY)
End Function

Function fGetLinkedTables() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As Database
Set db = CurrentDb
db.TableDefs.Refresh
For Each tdf In db.TableDefs
With tdf
If Len(.Connect) > 0 Then
If Left$(.Connect, 4) = "ODBC" Then
' collTables.Add Item:=.Name & ";" & .Connect,
KEY:=.Name
'ODBC Reconnect handled separately
Else
collTables.Add Item:=.Name & .Connect, Key:=.Name
End If
End If
End With
Next
Set fGetLinkedTables = collTables
Set collTables = Nothing
Set tdf = Nothing
Set db = Nothing
End Function

Function fParsePath(strIn As String) As String
If Left$(strIn, 4) <> "ODBC" Then
fParsePath = Right(strIn, Len(strIn) _
- (InStr(1, strIn, "DATABASE=") + 8))
Else
fParsePath = strIn
End If
End Function

Function fParseTable(strIn As String) As String
fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Code End ***************
 
A

Andreas

Hi Chris,

thanks for the very quick reply!
Also, you commented out part of a
block but not the entire block of code, so the code is always raising an
error with

Err.Raise cERR_USERCANCEL

instead of only when the user presses the No button.
Sorry, this is due to formating in google: in the code it is all
commented (all in green). When I run it in the mde it works.
Access won't create an MDE because the code doesn't compile. You haven't
defined ahtAddFilterItem, ahtCommonFileOpenSave, and ahtOFN_HIDEREADONLY, but
your procedure is trying to use them.
Thanks! Actually I used this code but I am not an expert in VBA. Can I
do anything to solve this problem (do I need this part of the code?)
and still use the code as before (to link the tables automatically
relative to the back end)?

Thank you very much,

Andreas
 
A

Andreas

Hi folks,

sorry, stupid me, I CAN delete the code but didn't try it - sorry. Now
it works!

Andreas
 
A

Andreas

Hi,
Since it works, does that mean you can now create the MDE?
YES, without the function I can create a MDE - very helpful thank you!
I think the function is only neccessary for the dialog form (which I
dont need as I have it in the same folder as the back end db. (see
code below)
In the Code Module, if you click Debug, do you get an error message?
For Evi's question: YES, even with the code I deleted I can RUN it
without problems, but I can't create the mde.

Thanks again,

Andreas

Function fGetMDBName(strIn As String) As String
'Andi: MDE doesnt work with this function, but not needed
''Calls GetOpenFileName dialog
'Dim strFilter As String
'
' strFilter = ahtAddFilterItem(strFilter, _
' "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
' "*.mdb; *.mda; *.mde; *.mdw")
' strFilter = ahtAddFilterItem(strFilter, _
' "All Files (*.*)", _
' "*.*")
'
' fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
' OpenFile:=True, _
' DialogTitle:=strIn, _
' Flags:=ahtOFN_HIDEREADONLY)
'Andi: end altered
End Function
 
E

Evi

What is the line that the debug highlights?
Evi

Andreas said:
Hi,

YES, without the function I can create a MDE - very helpful thank you!
I think the function is only neccessary for the dialog form (which I
dont need as I have it in the same folder as the back end db. (see
code below)

For Evi's question: YES, even with the code I deleted I can RUN it
without problems, but I can't create the mde.

Thanks again,

Andreas

Function fGetMDBName(strIn As String) As String
'Andi: MDE doesnt work with this function, but not needed
''Calls GetOpenFileName dialog
'Dim strFilter As String
'
' strFilter = ahtAddFilterItem(strFilter, _
' "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
' "*.mdb; *.mda; *.mde; *.mdw")
' strFilter = ahtAddFilterItem(strFilter, _
' "All Files (*.*)", _
' "*.*")
'
' fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
' OpenFile:=True, _
' DialogTitle:=strIn, _
' Flags:=ahtOFN_HIDEREADONLY)
'Andi: end altered
End Function
 
A

Andreas

If you paste the code on this pagehttp://www.mvps.org/access/api/api0001.htminto another standardmodule, you
can uncomment the code in fGetMDBName, then save and compile, and it should
work. Your first codemodulewas missing those functions called in
fGetMDBName.

ok, just did that and the creation of the MDE works! (copy code in a
new module, uncomment fGetMDBName and create MDE).

I have to admit that I do a little bit VBA but this is something like
a black box... but it works. So thank you very much, you have helped
me a lot!

Andreas
 
T

Tony Toews [MVP]

Andreas said:
Does anybody knows what the problem is? (I altered the code slightly
in the beginning: 'Andi..., but this shouldn't be a problem I think).

Is Option Explicit present in the first few lines of the code module?
If not add it and then compile.

Tony
--
Tony Toews, Microsoft Access MVP
Please respond only in the newsgroups so that others can
read the entire thread of messages.
Microsoft Access Links, Hints, Tips & Accounting Systems at
http://www.granite.ab.ca/accsmstr.htm
Tony's Microsoft Access Blog - http://msmvps.com/blogs/access/
 
A

Andreas

Is Option Explicit present in the first few lines of the codemodule?
If not add it and then compile.
Yes, it was. But now, with the help of Chris' reply (12) it works
great!

Andreas
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top