Closing Excel files from Access and/or quitting Excel from Access

  • Thread starter Thread starter Beverly
  • Start date Start date
B

Beverly

I hope I am not asking too much here. Basically I have a
program launched by pressing a button that cycles through
a table to create the Excel file name. After it splices
together the file name it goes to a second program called
GetExcel.

With each cycle through, GetExcel opens Excel if
necessary, selects the file and opens it, creates a new
worksheet and copies the data from its worksheet called
Summary to the new worksheet called Import Data. Then
Access imports the Import Data successfully putting it
into a table.

All this works fine.

My problem is, I want to either close down Excel after
all the files have cycled through and/or close each Excel
file after its data is imported by Access.

I am including the two programs. The second program has
some other subroutines that do things like check to make
sure Excel is running or not, etc. The
DetectExcelandTerminate subroutine is what I am trying to
use to close Excel. The ActiveWorkbook.Close
SaveChanges:=False is what I am trying to use to close
each Excel file one by one, but no luck. Any ideas would
be very much appreciated. I need an answer ASAP.

1st Program:
Private Sub Roll_Click()
'On Error GoTo Err_Roll_Click
Dim strPath As String
Dim tbDistrict As DAO.Recordset
DoCmd.Hourglass True

DoCmd.SetWarnings False
DoCmd.OpenQuery "ClearData", acNormal, acEdit
DoCmd.SetWarnings True
Set tbDistrict = CurrentDb.OpenRecordset("Districts",
dbOpenTable)
If Not tbDistrict.EOF Then
tbDistrict.MoveFirst
Do Until tbDistrict.EOF
strPath = Me.Path
If FileName = 1 Then
strPath = strPath & tbDistrict![OldBu]
Else
strPath = strPath & tbDistrict![BU]
End If
strPath = strPath & "-" & Me.Yr.Value & ".xls"
GetExcel strPath, Me.Heading
tbDistrict.MoveNext
Loop
End If

DoCmd.Hourglass False
DetectExcelandterminate


Second program plus related subroutines:

Option Compare Database
Option Explicit

' Declare necessary API routines:
Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long

Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


Public Sub GetExcel(strPath As String, strColHead As
String)
Dim myxl As Object
Dim strRange1 As String, strRange2 As String,
strRange3 As String
Dim strRow1 As String, strRow2 As String, strRow3 As
String
Dim strCol1 As String, strCol2 As String, strCol3 As
String
Dim i As Integer, j As Integer, X As Integer, Y As
Integer
Dim ExcelWasNotRunning As Boolean
On Error Resume Next
Set myxl = GetObject(, "Excel.Application")
If Err.Number <> 0 Then ExcelWasNotRunning = True
Err.Clear

DetectExcel

'On Error GoTo Err_GetExcel
Set myxl = GetObject(strPath)
If Err.Number = 432 Then
MsgBox "Unable to Locate file " & strPath,
vbCritical, "Error Opening File"
GoTo Exit_GetExcel
End If
myxl.Application.Visible = True
myxl.Parent.Windows(1).Visible = True


i = 1

With myxl
.Sheets.Add
.ActiveSheet.Name = "ImportData"
.ActiveSheet.Range("A1").Formula = "BU"
.ActiveSheet.Range("B1").Formula = "AccountID"
.ActiveSheet.Range("C1").Formula = "Year"
.ActiveSheet.Range("D1").Formula = "Cost"
End With

myxl.Sheets("Summary").Range("A2").Select
' myxl.ActiveSheet.Range("A2").Select
Do Until myxl.Sheets("Summary").Cells(i, 1) = "Account"
i = i + 1
Loop
i = i + 1
strRange1 = "A" & i
If Len(myxl.Sheets("Summary").Range(strRange1)) < 6
Then
j = 2
Else
j = 1
End If
strCol1 = ConvertToAlpha(j)
strCol2 = ConvertToAlpha(j + 1)
Do Until myxl.Sheets("Summary").Cells(i - 1, j) =
strColHead '"@ 08/22/03"
j = j + 1
Loop
strCol3 = ConvertToAlpha(j)
X = i
Y = 1
Do Until myxl.Sheets("Summary").Cells(X, 2) = ""
X = X + 1
Y = Y + 1
Loop
strRange1 = strCol1 & i & ":" & strCol2 & X & "," &
strCol3 & i & ":" & strCol3 & X
myxl.Sheets("summary").Select
myxl.Sheets("Summary").Range(strRange1).Copy
myxl.Sheets("ImportData").Select
' myxl.ActiveSheet.Range("b2").PasteSpecial
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
' False, Transpose:=False
myxl.Sheets("ImportData").Range("b2").PasteSpecial
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Application.CutCopyMode = False Excel
recognizes this but Access does not

SendKeys "{esc}", False





i = Y
j = 2
myxl.Sheets("ImportData").Select

For j = 2 To i
myxl.ActiveSheet.Cells(j, 1).Formula = Left
(myxl.Name, 3)
Next
strRange1 = "ImportData!A1:D" & j - 1
DoCmd.TransferSpreadsheet acImport,
acSpreadsheetTypeExcel3, "rcnld_data", strPath, -1,
strRange1

myxl.Sheets("ImportData").Select

ActiveWorkbook.Close SaveChanges:=False
Set myxl = Nothing

Exit_GetExcel:
If ExcelWasNotRunning = True Then
myxl.Application.DisplayAlerts = False
myxl.Application.Quit
myxl.Application.DisplayAlerts = True
End If
Set myxl = Nothing
Exit Sub

Err_GetExcel:
MsgBox Err.Description
Resume Exit_GetExcel

End Sub


Sub DetectExcel()
' Procedure dectects a running Excel and registers it.
Const WM_USER = 1024
Dim hWnd As Long
' If Excel is running this API call returns its handle.
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 means Excel not running.
Exit Sub
Else
' Excel is running so use the SendMessage API
' function to enter it in the Running Object Table.
SendMessage hWnd, WM_USER + 18, 0, 0
End If
End Sub

Sub DetectExcelandterminate()
' Procedure detects a running Excel and registers it.
Const WM_USER = 1024

Dim hWnd As Long
Dim myxl As Object

' If Excel is running this API call returns its handle.
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 means Excel not running.
Exit Sub
Else
' Excel is running so use the SendMessage API
' function to enter it in the Running Object Table.
SendMessage hWnd, WM_USER + 18, 0, 0
Application.Quit
SendKeys "{esc}", False


End If
End Sub

Thanks much.

Beverly
 
Beverly
My problem is, I want to either close down Excel after
all the files have cycled through and/or close each Excel
file after its data is imported by Access.
Click to expand...

The following changes will achieve the first objective
(ie close Excel after all files processed):

PROGRAM 1

The following change to program 1 starts Excel
before the loop and quits Excel after the loop so
that the same copy of Excel can be used for all
XLS files:

Private Sub Roll_Click()

On Error GoTo HandleErrors
Dim strPath As String
Dim tbDistrict As DAO.Recordset
DoCmd.Hourglass True

DoCmd.SetWarnings False
DoCmd.OpenQuery "ClearData", acNormal, acEdit
DoCmd.SetWarnings True

' Start Excel before the "tbDistrict" loop. To do this,
' call the new "blnStartExcel" subprocedure in standard module:
If Not blnStartExcel Then GoTo Bye

Set tbDistrict = CurrentDb.OpenRecordset("Districts", dbOpenTable)
If Not tbDistrict.EOF Then
tbDistrict.MoveFirst
Do Until tbDistrict.EOF
strPath = Me.Path
If Filename = 1 Then
strPath = strPath & tbDistrict![OldBu]
Else
strPath = strPath & tbDistrict![BU]
End If
strPath = strPath & "-" & Me.Yr.Value & ".xls"
GetExcel strPath, Me.Heading
tbDistrict.MoveNext
Loop
End If

DoCmd.Hourglass False

' QUIT Excel after loop. To do this, call the new
' "QuitExcel" subprocedure in the standard module:
QuitExcel

Bye:
Exit Sub

HandleErrors:
DoCmd.Hourglass False
MsgBox Err.Description, vbOKOnly, "Error No: " & Err.Number
Resume Bye

End Sub


PROGRAM 2 (STANDARD MODULE):

Program 2 below:

1. Declares myxl as an Excel Application
(assumes reference to Excel Object Library,
Tools, References in vba editor).

2. Declares 'myxl' and 'ExcelWasNotRunning'
as variables with module scope.

3. Has a new function: blnStartExcel to start
Excel before the loop.

4. Has a new subprocedure: QuitExcel to
quit Excel after the loop.

5. Uses:
myxl.Workbooks.Open Filename:=strPath
to open XLS files.

6. Traps error 1004 (XLS file missing).

7. Does not make API declarations as the
following are not used:
DetectExcel
DetectExcelandterminate


Dim myxl As Excel.Application
Dim ExcelWasNotRunning As Boolean

Public Function blnStartExcel() As Boolean
' Return false if Excel cannot be started.

On Error GoTo HandleErrors
blnStartExcel = False
Set myxl = GetObject(, "Excel.Application")
myxl.Application.Visible = True
blnStartExcel = True

Bye:
Exit Function

HandleErrors:
If Err.Number = 429 Then
' Excel is not running, so start Excel:
Set myxl = CreateObject("Excel.Application")
ExcelWasNotRunning = True
Resume Next
Else
DoCmd.Hourglass False
MsgBox Err.Description, vbOKOnly, "Error No: " & Err.Number
Resume Bye
End If
Resume Bye

End Function


Public Sub GetExcel(strPath As String, strColHead As String)

Dim strRange1 As String, strRange2 As String, strRange3 As String
Dim strRow1 As String, strRow2 As String, strRow3 As String
Dim strCol1 As String, strCol2 As String, strCol3 As String
Dim i As Integer, j As Integer, X As Integer, Y As Integer

On Error GoTo Err_GetExcel

myxl.Workbooks.Open Filename:=strPath

i = 1

With myxl
.Sheets.Add
.ActiveSheet.Name = "ImportData"
.ActiveSheet.Range("A1").Formula = "BU"
.ActiveSheet.Range("B1").Formula = "AccountID"
.ActiveSheet.Range("C1").Formula = "Year"
.ActiveSheet.Range("D1").Formula = "Cost"
End With

myxl.Sheets("Summary").Range("A2").Select
' myxl.ActiveSheet.Range("A2").Select
Do Until myxl.Sheets("Summary").Cells(i, 1) = "Account"
i = i + 1
Loop
i = i + 1
strRange1 = "A" & i
If Len(myxl.Sheets("Summary").Range(strRange1)) < 6 Then
j = 2
Else
j = 1
End If
strCol1 = ConvertToAlpha(j)
strCol2 = ConvertToAlpha(j + 1)
Do Until myxl.Sheets("Summary").Cells(i - 1, j) = strColHead '"@
08/22/03"
j = j + 1
Loop
strCol3 = ConvertToAlpha(j)
X = i
Y = 1
Do Until myxl.Sheets("Summary").Cells(X, 2) = ""
X = X + 1
Y = Y + 1
Loop
strRange1 = strCol1 & i & ":" & strCol2 & X & "," & strCol3 & i & ":" &
strCol3 & X
myxl.Sheets("summary").Select
myxl.Sheets("Summary").Range(strRange1).Copy
myxl.Sheets("ImportData").Select
' myxl.ActiveSheet.Range("b2").PasteSpecial _
' Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
' False, Transpose:=False
myxl.Sheets("ImportData").Range("b2").PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Application.CutCopyMode = False ' Excel recognizes this but Access
does not

SendKeys "{esc}", False

i = Y
j = 2
myxl.Sheets("ImportData").Select

For j = 2 To i
myxl.ActiveSheet.Cells(j, 1).Formula = Left(myxl.Name, 3)
Next
strRange1 = "ImportData!A1:D" & j - 1
DoCmd.TransferSpreadsheet acImport, _
acSpreadsheetTypeExcel3, "rcnld_data", strPath, -1, _
strRange1

myxl.Sheets("ImportData").Select

ActiveWorkbook.Close SaveChanges:=False

Exit_GetExcel:
Exit Sub

Err_GetExcel:
If Err.Number = 1004 Then
' Error number is 1004 if Excel file is missing:
MsgBox "Unable to Locate file " & _
strPath, vbCritical, "Error Opening File"
Else
MsgBox Err.Description, vbOKOnly, "Error No: " & CStr(Err.Number)
End If
Resume Exit_GetExcel

End Sub

Public Sub QuitExcel()
If ExcelWasNotRunning Then
myxl.DisplayAlerts = False
myxl.Quit
End If
Set myxl = Nothing
End Sub


Good luck with your project.
Regards
Geoff
 
Back
Top