Re: Opening Excel from Access

Hi Roger,

Thought you might be on to something, so rewrote the GetAccess() module
which still works. Bit more readable as all the examples of the arrays in
the AddConnection line were a foul mess.

Still same problem though

Phil

Function GetAccess()
'
' Macro1 Macro
' Macro recorded 26/03/2008 by Phil Stanton
'
Dim MDBName As String, DefaultDirectory As String, SQLStg As String

On Error GoTo GetAccess_Err

Worksheets("Linked Data").Activate
With Active***
MDBName = .Range("A1")

CheckFile:
If Dir(MDBName) = "" Then ' Not found
MDBName = Application.GetOpenFileName("Access Database ,*.mde",
, "Where is the Club Database?")
If MsgBox("Do you want to use this database in future?",
vbQuestion + vbYesNo) = vbYes Then
.Range("A1") = MDBName
End If
End If
End With

'
' Clear Cells

Active***.Range("A2:H300").ClearContents

SQLStg = "SELECT DISTINCT TypeOfSpace, Space, SpaceAndName, XPos, YPos,
XLabelPosition, YLabelPosition, LabelAngle "
SQLStg = SQLStg & "FROM QSpaceAllocation ORDER BY TypeOfSpace, Space"

DefaultDirectory = Left(MDBName, InStrRev(MDBName, "\"))

With Active***.QueryTables.Add(Connection:=Array(Array("ODBC;DSN=MS
Access Database;"), _
Array("DBQ=" & MDBName & ";"), _
Array("DefaultDir=" & DefaultDirectory & ";DriverId=25;"), _
Array("FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;" _
)), Destination:=Range("A2"))
.CommandText = Array(SQLStg)
.Name = "Query from MS Access Database"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=True
End With

Exit Function

GetAccess_Err:
Stop
If Err = 12 Then
ThisWorkbook.Close , False
Else
MsgBox Err.Description
End If

End Function
"Roger" <lesperancer@xxxxxxxxxx> wrote in message
news:382fc75b-fa2b-4300-a0d0-240fa5e0f047@xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
On May 25, 2:01 pm, "Phil Stanton" <p...@xxxxxxxxxxxxxxxxxx> wrote:
Thanks for coming back

Code is:-
Function GetAccess()
'
' Macro1 Macro
' Macro recorded 26/03/2008 by Phil Stanton
'
Dim MDBName As String, DefaultDirectory As String, SQLStg As String

On Error GoTo GetAccess_Err

Worksheets("Linked Data").Activate
With Active***
MDBName = .Range("A1")

CheckFile:
If Dir(MDBName) = "" Then ' Not found
MDBName = Application.GetOpenFileName("Access Database ,*.mde",
, "Where is the Club Database?")
If MsgBox("Do you want to use this database in future?",
vbQuestion + vbYesNo) = vbYes Then
.Range("A1") = MDBName
End If
End If
End With

'
' Clear Cells

Active***.Range("A2:H300").Clear

SQLStg = "SELECT DISTINCT TypeOfSpace, Space, SpaceAndName, XPos, YPos,
XLabelPosition, YLabelPosition, LabelAngle "
SQLStg = SQLStg & "FROM `" & MDBName & "`." ' Note the ` symbol.
Significant

DefaultDirectory = Left(MDBName, InStrRev(MDBName, "\"))

'DBName = "C:\WFYC Data\Phil's Folder\Access\MDB\Clubs New 2007"
'"ODBC;DSN=MS Access Database;DBQ=" & MDBName &
";DefaultDir=C:\WFYC Data\Phil's Folder\Acces"
With Active***.QueryTables.Add(Connection:=Array(Array( _
"ODBC;DSN=MS Access Database;DBQ=" & MDBName & ";DefaultDir=" &
DefaultDirectory _
), Array("s\MDB;DriverId=25;FIL=MS
Access;MaxBufferSize=2048;PageTimeout=5;")), _
Destination:=Range("A2"))
.CommandText = Array(SQLStg, "QSpaceAllocation QSpaceAllocation
ORDER BY TypeOfSpace, Space")
.Name = "Query from MS Access Database"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=True
End With

'Stop ' Has it got here?

Exit Function

GetAccess_Err:
Stop
If Err = 1234 Then ' No Idea what the error
code will be
ThisWorkbook.Close , False
Else
MsgBox Err.Description
End If

End Function

There is a lot of other code, but this is the bit where the data is
"extracted" from Access.
As I said, no problem whether the Access DB is open or not, the problem
comes when I click the button on Access form to show the Excel file.
The "Linked Data" work*** holds and processes the data, and the output
is
11 labelled scatter charts, one on each page (Map of boat compound and
where
each boat is stored)

Thanks again

Phil

"ByteMyzer" <bNyOtSePmAyMzN...@xxxxxxxxxxxxx> wrote in message

news:qqi_j.684$iM3.561@xxxxxxxxxxxxxxxxxxxxxxx



Please post the code that is in the Excel file. If that code refers to
the
database, then that is most likely where the error is occuring, in which
case, we might be better able to help you.

"Phil Stanton" <p...@xxxxxxxxxxxxxxxxxx> wrote in message
news:R8idnaH_C8VIEaTVnZ2dnUVZ8tPinZ2d@xxxxxxxxxxxxxxxxx
Sorry

Should have added

There is some code in the Excel application which refers to the
Database
and
extracts the relevant information

No problem opening Excel whether the database is open or not.

Phil

"Phil Stanton" <p...@xxxxxxxxxxxxxxxxxx> wrote in message
news:W82dnW2MNIyg8aTVnZ2dnUVZ8tfinZ2d@xxxxxxxxxxxxxxxxx
I have a form with a button which is supposed to open an Excel file
(With
lots of Macros /VBA) in it. The Excel file gets it's data from the
Access
program

Here is the code

Private Sub Storage_Click()

On Error GoTo Err_Storage_Click

Dim ExcelApp As Object
Dim ExcelWasNotRunning As Boolean ' Flag for final release
Dim XLFilePath As String
Dim XLName As String ' Excel file name from
Paths
Dim MyDb As Database
Dim Msg As String

' Find the normal path
' Folder and File
If Nz(ExcelPath) = "" Then
ExcelPath = "C:\Storage.XLS"
End If

XLName = Right(ExcelPath, Len(ExcelPath) - InStrRev(ExcelPath, "\"))
'
File Name

If Dir(ExcelPath) <> XLName Then ' Not found
XLFilePath = FindFile("C:\Documents and Settings\Phil\My
Documents\Access\MDB\WFYC\", XLName)
Msg = "The name of the file you have selected is " & vbCrLf
Msg = Msg & XLFilePath & vbCrLf
Msg = Msg & "but the original file was " & vbCrLf
Msg = Msg & ExcelPath & vbCrLf
Msg = Msg & "Do you want to use the new name in future?"
If MsgBox(Msg, vbQuestion + vbYesNo) = vbYes Then
ExcelPath = XLFilePath
End If
End If

Set ExcelApp = CreateObject("Excel.Application")

If Err.Number <> 0 Then ExcelWasNotRunning = True
Err.Clear ' Clear Err object in case error occurred.

' Set the object variable to reference the file you want to see.

Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.WorkBooks.Open ExcelPath, , True ' Read
Only
ExcelApp.Visible = True

Exit_Storage_Click:
Exit Sub

Err_Storage_Click:
If Err = 2447 Then ' Corrupted File name (with # sign)
Resume Next
Else
MsgBox Err.Description
Resume Exit_Storage_Click
End If

End Sub

When I run it, I get an Error Box "ODBC Microsoft Access Driver Login
Failed" and the message "The database has been placed in a state by
user
'Admin' on Machine 'PHIL-DESKTOP' that prevents it being opened or
locked"

What am I doing wrong

Thank

Phil- Hide quoted text -

- Show quoted text -

what's the name of the table being selected in the mdbname ?
SQLStg = "SELECT DISTINCT TypeOfSpace, Space, SpaceAndName, XPos,
YPos,
XLabelPosition, YLabelPosition, LabelAngle "
SQLStg = SQLStg & "FROM `" & MDBName & "`." ' Note the `
symbol.
Significant


.