getting extra excel instance when controlling from access VBA

D

Duane Wilson

I am writing a program in Access VBA to create an excel spreadsheet, import
data into it from Access queries, and format it. It works fine until I tried
putting a drop down list into it for data validation. Even that works, but I
am left with an instance of Excel in the task manager even though the
workbook has been closed and both the xlapp and xlworkbook has been set to
nothing. I can't even terminate the instance using a version of this code
that has only the get object parts and the close and set to nothing parts. It
recogizes that excel is open, grabs it; then when you do application.quit and
set to nothing, it just sits there in the task manager. Nothing seems to stop
it. Variations of this have been plaguing me for days. Please help.

'form module with 2 buttons, one which is not being used. Another form is in
db, but also not being used
Option Compare Database
Option Explicit
Dim xlsAppTest As Excel.Application
Dim xlsWorkbook As Excel.Workbook


Private Sub Command11_Click()
'************ Code Start **********

Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object

If fIsAppRunning("Excel") Then
Set objXL = GetObject(, "Excel.Application")
boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
boolXL = True
End If

objXL.Application.Workbooks.Add
Set objActiveWkb = objXL.Application.ActiveWorkbook

With objActiveWkb
.Worksheets(1).Cells(1, 1) = "Hello World"
strWhat = .Worksheets(1).Cells(1, 1).Value
End With
objXL.Visible = True
Stop
FormatTest objXL
Reason_PSYS objXL
objActiveWkb.Close savechanges:=True, FileName:="test" & Str(10120602)

If boolXL Then objXL.Application.Quit
objXL.Application.Quit
Set objActiveWkb = Nothing: Set objXL = Nothing
MsgBox strWhat
End Sub
'************ Code End **********
'module called Miscellaneous - nothing else here - works fine
Public Sub FormatTest(xlsApp As Excel.Application)
With xlsApp
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.ColorIndex = 39
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.Pattern = xlSolid
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.PatternColorIndex =
xlAutomatic
End With
End Sub

'mod_Reason_PSYS - a general modul
'Option Explicit
Dim xlApp As Excel.Application

Sub Reason_PSYS(ByVal xlApp As Excel.Application)
'Sub Reason_PSYS()
'
'
On Error GoTo Error_Handler
Dim i As Long
Dim f As Long

'xlapp.Workbooks(1).Sheets(2).Range("A1:D1").Borders(xlInsideVertical).ColorIndex = xlAutomatic
For i = 1 To 195
xlApp.Workbooks(1).Sheets(1).Cells(i, 1).Value = "Test"
Next i

xlApp.Workbooks(1).Sheets(1).Range("BA2").Value = "CORRECT"
xlApp.Workbooks(1).Sheets(1).Range("BA3").Value = "ERROR"
xlApp.Workbooks(1).Sheets(1).Range("BA4").Value = "EXCEPTION"

xlApp.Workbooks(1).Worksheets(2).Activate
xlApp.Workbooks(1).Worksheets(2).Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Worksheets(1).Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Sheets(1).Range("O2").Select
With xlApp.Workbooks(1).Sheets(1).Range("P2").Validation ', Cells(f,
16)
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Ba$2:$BA$4"
.IgnoreBlank = True
InCellDropdown = True
InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Stop
With xlApp.Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$BA$2:$BA$4"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
f = FindLastRow(xlApp)
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Sheets(1).Cells(2, 16).Select
xlApp.Selection.Copy
For i = 3 To f
xlApp.Workbooks(1).Sheets(1).Cells(i, 16).Select
xlApp.ActiveSheet.Paste
'xlApp.Workbooks(1).Worksheets(2).Paste
'xlApp.Workbooks(1).Worksheets.Select
Next i
xlApp.Workbooks(1).Sheets(1).Range("O1").Value = "REASON"
xlApp.Workbooks(1).Sheets(1).Range("P1").Value = "COMMENTS"
xlApp.Workbooks(1).Sheets(1).Columns("P:p").ColumnWidth = 31.29
xlApp.Workbooks(1).Sheets(1).Columns("O:p").Interior.ColorIndex = 38
xlApp.Workbooks(1).Sheets(1).Columns("O:p").Interior.Pattern = xlSolid
'Selection.Locked = False
'Selection.FormulaHidden = False
Exit_Handler:
Exit Sub
Error_Handler:
Debug.Print "Error: " & Err.Number & " " & Err.Description
Stop
Resume Next
Resume
Resume Exit_Handler

End Sub

Function FindLastRow(ByVal xlApp As Excel.Application)
Dim LastRow As Long
'If xlApp.Workbooks(1).Sheets(1).WorksheetFunction.Count(Cells) > 0 Then
'xlApp.WorksheetFunction.Count (Cells)
If xlApp.WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = xlApp.Workbooks(1).Sheets(1).Cells.Find(What:="*",
After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'MsgBox LastRow
End If
FindLastRow = LastRow
End Function


'Module IsAppRunning
Option Compare Database

'***************** 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
'
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

Private Declare Function apiFindWindow Lib "user32" Alias _
"FindWindowA" (ByVal strClass As String, _
ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
"SendMessageA" (ByVal Hwnd As Long, ByVal Msg As Long, ByVal _
wParam As Long, lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
"SetForegroundWindow" (ByVal Hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias _
"ShowWindow" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias _
"IsIconic" (ByVal Hwnd As Long) As Long

Function fIsAppRunning(ByVal strAppName As String, _
Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
Case "excel": strClassName = "XLMain"
Case "word": strClassName = "OpusApp"
Case "access": strClassName = "OMain"
Case "powerpoint95": strClassName = "PP7FrameClass"
Case "powerpoint97": strClassName = "PP97FrameClass"
Case "notepad": strClassName = "NOTEPAD"
Case "paintbrush": strClassName = "pbParent"
Case "wordpad": strClassName = "WordPadClass"
Case Else: strClassName = vbNullString
End Select

If strClassName = "" Then
lngH = apiFindWindow(vbNullString, strAppName)
Else
lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
apiSendMessage lngH, WM_USER + 18, 0, 0
lngX = apiIsIconic(lngH)
If lngX <> 0 Then
lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
End If
If fActivate Then
lngTmp = apiSetForegroundWindow(lngH)
End If
fIsAppRunning = True
End If
fIsAppRunning_Exit:
Exit Function
fIsAppRunning_Err:
fIsAppRunning = False
Resume fIsAppRunning_Exit
End Function
'******************** Code End ****************
 
V

Vacation's Over

documented bug in this from MS

something about refering to second isnstance and using With

With objActiveWkb
try writing it all aout without with...

Duane Wilson said:
I am writing a program in Access VBA to create an excel spreadsheet, import
data into it from Access queries, and format it. It works fine until I tried
putting a drop down list into it for data validation. Even that works, but I
am left with an instance of Excel in the task manager even though the
workbook has been closed and both the xlapp and xlworkbook has been set to
nothing. I can't even terminate the instance using a version of this code
that has only the get object parts and the close and set to nothing parts. It
recogizes that excel is open, grabs it; then when you do application.quit and
set to nothing, it just sits there in the task manager. Nothing seems to stop
it. Variations of this have been plaguing me for days. Please help.

'form module with 2 buttons, one which is not being used. Another form is in
db, but also not being used
Option Compare Database
Option Explicit
Dim xlsAppTest As Excel.Application
Dim xlsWorkbook As Excel.Workbook


Private Sub Command11_Click()
'************ Code Start **********

Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object

If fIsAppRunning("Excel") Then
Set objXL = GetObject(, "Excel.Application")
boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
boolXL = True
End If

objXL.Application.Workbooks.Add
Set objActiveWkb = objXL.Application.ActiveWorkbook

With objActiveWkb
.Worksheets(1).Cells(1, 1) = "Hello World"
strWhat = .Worksheets(1).Cells(1, 1).Value
End With
objXL.Visible = True
Stop
FormatTest objXL
Reason_PSYS objXL
objActiveWkb.Close savechanges:=True, FileName:="test" & Str(10120602)

If boolXL Then objXL.Application.Quit
objXL.Application.Quit
Set objActiveWkb = Nothing: Set objXL = Nothing
MsgBox strWhat
End Sub
'************ Code End **********
'module called Miscellaneous - nothing else here - works fine
Public Sub FormatTest(xlsApp As Excel.Application)
With xlsApp
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.ColorIndex = 39
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.Pattern = xlSolid
.Workbooks(1).Sheets(2).Range("A1:D1").Interior.PatternColorIndex =
xlAutomatic
End With
End Sub

'mod_Reason_PSYS - a general modul
'Option Explicit
Dim xlApp As Excel.Application

Sub Reason_PSYS(ByVal xlApp As Excel.Application)
'Sub Reason_PSYS()
'
'
On Error GoTo Error_Handler
Dim i As Long
Dim f As Long

'xlapp.Workbooks(1).Sheets(2).Range("A1:D1").Borders(xlInsideVertical).ColorIndex = xlAutomatic
For i = 1 To 195
xlApp.Workbooks(1).Sheets(1).Cells(i, 1).Value = "Test"
Next i

xlApp.Workbooks(1).Sheets(1).Range("BA2").Value = "CORRECT"
xlApp.Workbooks(1).Sheets(1).Range("BA3").Value = "ERROR"
xlApp.Workbooks(1).Sheets(1).Range("BA4").Value = "EXCEPTION"

xlApp.Workbooks(1).Worksheets(2).Activate
xlApp.Workbooks(1).Worksheets(2).Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Worksheets(1).Range("A2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Sheets(1).Range("O2").Select
With xlApp.Workbooks(1).Sheets(1).Range("P2").Validation ', Cells(f,
16)
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Ba$2:$BA$4"
.IgnoreBlank = True
InCellDropdown = True
InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Stop
With xlApp.Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$BA$2:$BA$4"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
f = FindLastRow(xlApp)
xlApp.Workbooks(1).Worksheets(1).Activate
xlApp.Workbooks(1).Sheets(1).Cells(2, 16).Select
xlApp.Selection.Copy
For i = 3 To f
xlApp.Workbooks(1).Sheets(1).Cells(i, 16).Select
xlApp.ActiveSheet.Paste
'xlApp.Workbooks(1).Worksheets(2).Paste
'xlApp.Workbooks(1).Worksheets.Select
Next i
xlApp.Workbooks(1).Sheets(1).Range("O1").Value = "REASON"
xlApp.Workbooks(1).Sheets(1).Range("P1").Value = "COMMENTS"
xlApp.Workbooks(1).Sheets(1).Columns("P:p").ColumnWidth = 31.29
xlApp.Workbooks(1).Sheets(1).Columns("O:p").Interior.ColorIndex = 38
xlApp.Workbooks(1).Sheets(1).Columns("O:p").Interior.Pattern = xlSolid
'Selection.Locked = False
'Selection.FormulaHidden = False
Exit_Handler:
Exit Sub
Error_Handler:
Debug.Print "Error: " & Err.Number & " " & Err.Description
Stop
Resume Next
Resume
Resume Exit_Handler

End Sub

Function FindLastRow(ByVal xlApp As Excel.Application)
Dim LastRow As Long
'If xlApp.Workbooks(1).Sheets(1).WorksheetFunction.Count(Cells) > 0 Then
'xlApp.WorksheetFunction.Count (Cells)
If xlApp.WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = xlApp.Workbooks(1).Sheets(1).Cells.Find(What:="*",
After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'MsgBox LastRow
End If
FindLastRow = LastRow
End Function


'Module IsAppRunning
Option Compare Database

'***************** 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
'
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

Private Declare Function apiFindWindow Lib "user32" Alias _
"FindWindowA" (ByVal strClass As String, _
ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
"SendMessageA" (ByVal Hwnd As Long, ByVal Msg As Long, ByVal _
wParam As Long, lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
"SetForegroundWindow" (ByVal Hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias _
"ShowWindow" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias _
"IsIconic" (ByVal Hwnd As Long) As Long

Function fIsAppRunning(ByVal strAppName As String, _
Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
Case "excel": strClassName = "XLMain"
Case "word": strClassName = "OpusApp"
Case "access": strClassName = "OMain"
Case "powerpoint95": strClassName = "PP7FrameClass"
Case "powerpoint97": strClassName = "PP97FrameClass"
Case "notepad": strClassName = "NOTEPAD"
Case "paintbrush": strClassName = "pbParent"
Case "wordpad": strClassName = "WordPadClass"
Case Else: strClassName = vbNullString
End Select

If strClassName = "" Then
lngH = apiFindWindow(vbNullString, strAppName)
Else
lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
apiSendMessage lngH, WM_USER + 18, 0, 0
lngX = apiIsIconic(lngH)
If lngX <> 0 Then
lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
End If
If fActivate Then
lngTmp = apiSetForegroundWindow(lngH)
End If
fIsAppRunning = True
End If
fIsAppRunning_Exit:
Exit Function
fIsAppRunning_Err:
fIsAppRunning = False
Resume fIsAppRunning_Exit
End Function
'******************** Code End ****************
Click to expand...
 
J

Jim Cone

Duane,

Just looking at the first portion of your code...
I have made some changes that could help. (untested)
The workbook and worksheet objects are set to nothing
before quitting the application.
A separate object reference is used for the worksheet.
Use of the "With" construct was eliminated.
Eliminated references to anything "Active".

Regards,
Jim Cone
San Francisco, USA

'--------------------------
Private Sub Command11_Click()
Dim strWhat As String
Dim boolXL As Boolean
Dim objXL As Excel.Application
Dim objWorkSht As Excel.Worksheet
Dim objActiveWkb As Excel.Workbook

If fIsAppRunning("Excel") Then
Set objXL = GetObject(, "Excel.Application")
boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
boolXL = True
End If

Set objActiveWkb = objXL.Workbooks.Add
Set objWorkSht = objActiveWkb.Worksheets(1)

objWorkSht.Cells(1, 1).Value = "Hello World"
strWhat = objWorkSht.Cells(1, 1).Value
objXL.Visible = True
Stop
FormatTest objXL
Reason_PSYS objXL
Set objWorkSht = Nothing
objActiveWkb.Close savechanges:=True, Filename:="test" & VBA.Str(10120602)
Set objActiveWkb = Nothing
If boolXL Then objXL.Application.Quit
Set objXL = Nothing
MsgBox strWhat
End Sub
'------------------------------------


"Duane Wilson" <Duane (e-mail address removed)>
wrote in message
I am writing a program in Access VBA to create an excel spreadsheet, import
data into it from Access queries, and format it. It works fine until I tried
putting a drop down list into it for data validation. Even that works, but I
am left with an instance of Excel in the task manager even though the
workbook has been closed and both the xlapp and xlworkbook has been set to
nothing. I can't even terminate the instance using a version of this code
that has only the get object parts and the close and set to nothing parts. It
recogizes that excel is open, grabs it; then when you do application.quit and
set to nothing, it just sits there in the task manager. Nothing seems to stop
it. Variations of this have been plaguing me for days. Please help.

'form module with 2 buttons, one which is not being used. Another form is in
db, but also not being used
Option Compare Database
Option Explicit
Dim xlsAppTest As Excel.Application
Dim xlsWorkbook As Excel.Workbook


Private Sub Command11_Click()
'************ Code Start **********

Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objActiveWkb As Object

If fIsAppRunning("Excel") Then
Set objXL = GetObject(, "Excel.Application")
boolXL = False
Else
Set objXL = CreateObject("Excel.Application")
boolXL = True
End If

objXL.Application.Workbooks.Add
Set objActiveWkb = objXL.Application.ActiveWorkbook

With objActiveWkb
.Worksheets(1).Cells(1, 1) = "Hello World"
strWhat = .Worksheets(1).Cells(1, 1).Value
End With
objXL.Visible = True
Stop
FormatTest objXL
Reason_PSYS objXL
objActiveWkb.Close savechanges:=True, FileName:="test" & Str(10120602)

If boolXL Then objXL.Application.Quit
objXL.Application.Quit
Set objActiveWkb = Nothing: Set objXL = Nothing
MsgBox strWhat
End Sub
'************ Code End **********

- snip -
 

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

Similar Threads

converting VBA password-masking code to 64-bit 0
VBA for Dependents shortcut menu 0
Sound repeats unending until closing workbook 2
Assign a sound to a variable 19
Closing PDF file from Excel VBA (Adobe Reader, Adobe Acrobat, Browser) 0
Show/Hide Minimize/Maximize Button in Excel 2007/2010 2
Automatically copy with save? 8
Check a file into SharePoint 2

Top