Excel.Application not closed excel file - excel

I want to read some data from excel file and close it.
but my code not closed it:
Function getColumnOfFirstRow(PATH, size) As Long
Dim oApp_Excel As Excel.Application
Dim oBook As Excel.Workbook
Dim column As Long
column = 0
Set oApp_Excel = CreateObject("EXCEL.APPLICATION")
oApp_Excel.DisplayAlerts = False
oApp_Excel.Visible = True
Set oBook = oApp_Excel.Workbooks.Open(PATH, ReadOnly:=True)
On Error GoTo errhand
column = oBook.Sheets("Sheet1").Cells.Find(What:=CStr(size)).column
oBook.Close True
oApp_Excel.Quit
Set oBook = Nothing
errhand:
Select Case Err.Number
Case 91
column = 0
End Select
getColumnOfFirstRow = column
End Function
I think this part of my code must close it:
oBook.Close True
oApp_Excel.Quit

Using a New Instance of Excel
It looks like overkill to open and close Excel and a workbook to just retrieve a number but let's say we're practicing handling objects and error handling.
Function GetSizeColumn(ByVal Path As String, ByVal Size As Double) As Long
On Error GoTo ClearError
Dim xlApp As Excel.Application: Set xlApp = New Excel.Application
xlApp.Visible = True ' out-comment when done testing
Dim wb As Excel.Workbook
Set wb = xlApp.Workbooks.Open(Path, True, True)
Dim SizeColumn As Long
SizeColumn = wb.Sheets("Sheet1").Rows(1).Find(CStr(Size)).Column
' You can avoid the expected error as you have learned in your newer post.
' In this case, if the error occurs, the function will end up with
' its initial value 0 since its result is declared 'As Long'
' i.e. the following line will never be executed.
GetSizeColumn = SizeColumn
ProcExit:
On Error Resume Next
If Not wb Is Nothing Then wb.Close False
If Not xlApp Is Nothing Then xlApp.Quit
On Error GoTo 0
Exit Function
ClearError:
Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
Resume ProcExit
End Function

Try it. 100% working code about creating the excel. In this code, excel converts recordset in excel successfully. After that close the excel successfully. No error.
Also, check with the Task manager and close any excel file open in the process.
Public Sub ConvertRecordSetToExcelFull(Rs As Recordset, _
FileNameWithPath As String, _
SheetName As String, _
Rangename As String)
On Error GoTo Error1
Dim ExlFile As Object, Book As Object, Sheet As Object, K As Long, J As Long
Set ExlFile = CreateObject("Excel.Application")
Set Book = ExlFile.Workbooks.Add
Set Sheet = Book.Worksheets(1)
ExlFile.DisplayAlerts = False
K = 1
For J = 0 To Rs.Fields.Count - 1
Sheet.Cells(K, J + 1) = UCase(Rs.Fields(J).Name)
Next
K = K + 1
If Rs.RecordCount >= 1 Then
'Call RecCount(rs)
Do While Rs.EOF <> True
For J = 0 To Rs.Fields.Count - 1
Sheet.Cells(K, J + 1) = Rs.Fields(J)
Next
K = K + 1
Rs.MoveNext
Loop
End If
Book.Worksheets(1).Name = SheetName
Book.SaveAs FileNameWithPath
ExlFile.ActiveWorkbook.Close False
ExlFile.Quit
Set Sheet = Nothing
Set ExlFile = Nothing
Screen.MousePointer = vbNormal
Exit Sub
Error1:
MsgBox Err.Description
Err.Clear
End Sub

Related

Closing an Excel Application using Outlook VBA after using an Excel function

I am working on a sort of "BOT" for Outlook (using Outlook VBA), in which I receive info by mail, split the mail body, paste it on Excel and execute Excel macros.
After adding the part where I call the Excel macro, I get
'1004 - application-defined or object-defined error'
if I'm running this for the second + time.
xlApp.Application.Run "AINT.Cali_B_Click"
Even though I'm setting my Excel variables to nothing and using .close and .quit, Excel is still running.
How can I end the application reference that is keeping Excel open?
Here's my full code:
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
Dim splitter() As String
Dim splitter2() As String
Dim loopH As String
Dim str As Variant
Dim LoopCali As Integer
Dim i, j As Integer
Dim xlApp As Object
Dim sourceWB As Object
Dim Header, QuoteSTG, AINT, Treinamento As Object
Dim strFile, file_name As String
Dim shellcom As String
i = 1
If TypeName(Item) = "MailItem" Then
If InStr(Item.Subject, "BOT") > 0 Then
splitter = Split(Item.Body, vbCrLf)
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\Users\e1257539\Desktop\SMOBOT\SMO_TOOL_BOT.xlsm"
With xlApp
.Visible = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set sourceWB = Workbooks.Open(strFile)
sourceWB.Activate
Set Header = sourceWB.Sheets(4)
Set QuoteSTG = sourceWB.Sheets(13)
Set AINT = sourceWB.Sheets(7)
Set Treinamento = sourceWB.Sheets(10)
file_name = QuoteSTG.Range("A" + CStr(QuoteSTG.Range("B1").Value2)).Value2
QuoteSTG.Range("A" + CStr(QuoteSTG.Range("B1").Value2)).Value2 = ""
If splitter(2) = "Calibração" Then
loopH = splitter(26)
LoopCali = CInt(loopH)
sourceWB.Save
Header.Range("D6").Value2 = splitter(22)
Header.Range("D8").Value2 = splitter(12)
Header.Range("F4").Value2 = "AINT"
Header.Range("F3").Value2 = "EXW"
Header.Range("C2").Value2 = file_name
Header.Range("C4").Value2 = "Calibração"
Header.Range("L2").Value2 = "30"
Header.Range("K12").Value2 = Item.Subject '< criar string?
j = 40
For i = 1 To LoopCali
splitter2 = Split(splitter(j), "-")
AINT.Range("N7").Value2 = splitter2(0)
AINT.Range("N13").Value2 = splitter2(1)
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N14").Value2 = splitter(j)
End If
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N16").Value2 = splitter(j)
End If
j = j + 2
If splitter(j) <> "" Then
If splitter2(0) <> "RMT" Then
AINT.Range("N15").Value2 = splitter(j)
End If
End If
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N17").Value2 = splitter(j)
End If
j = j + 2
xlApp.Application.Run "AINT.Cali_B_Click" '< calling the excel sub
Next i
End If
End If
End If
'Closing excel
MkDir "C:\Users\e1257539\Desktop\SMOBOT\" + file_name
sourceWB.SaveAs FileName:="C:\Users\e1257539\Desktop\SMOBOT\" + file_name + "\" + file_name
sourceWB.Close (False)
xlApp.Quit
Set xlApp = Nothing
Set sourceWB = Nothing
Set AINT = Nothing
Set QuoteSTG = Nothing
Set Header = Nothing
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
If Not sourceWB Is Nothing Then
sourceWB.Close (False)
End If
If Not xlApp Is Nothing Then
xlApp.Quit
End If
Set xlApp = Nothing
Set sourceWB = Nothing
Set AINT = Nothing
Set QuoteSTG = Nothing
Set Header = Nothing
End Sub
Turns out using xlApp.Application.Run "AINT.Cali_B_Click" or xlApp.Application.Run sourceWB.Name & "AINT.Cali_B_Click" left open references on the VBA code.
The way to call the code without lefting any open is using CallByName,
As in Call CallByName(AINT, "Cali_B_Click", VbMethod)
This way the VBA code can call the function and run as many times as needed without the current error.

Popolate collection from external file, then close file, and show collection items

Is possible to popolate one pubblic collection from one external file?!?!?
I can't show the collection items,
to test this code I tried to loop the collection's item then
if the loop is before close the wb source, the result show right
but if I close che wb source I can only count the items collection.item = 31 (right result) if I try debug.print collection(x) 'x are integer from 1 to 31
I retrieve only Error 424.
Is my code, wrong, or is not possible to polulate one collection from an external file and, in this case what I've to use?!?!
Below my code:
option explicit
public Belts as collection
Public Sub mCaricaBelts()
On Error GoTo RigaErrore
Dim wb As Workbook, wbn As String
Dim sh As Worksheet
Dim rng As Range
Dim c As Range, v As Variant
Dim lrw As Long
With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = _
"Sto caricato la tabella Fasce"
End With
wbn = "Listino.xlsx"
If Not Belts Is Nothing Then
Set Belts = Nothing
End If
Set Belts = New Collection
If AlreadyOpen(wbn) Then
Set wb = Workbooks(wbn)
Else
Set wb = Workbooks.Open("\\itcpifs01\license$\Listino.xlsx")
End If
Set rng = wb.Worksheets("dbRatesSTD").Range("C1")
Set rng = Range(rng, rng.End(xlToRight))
For Each c In rng
Belts.Add c
Next
' if I put the loop here, I can show results
For Each v In Belts
Debug.Print v
Next
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
' if I put the loop here, I can't show results, Error 424 Object required
For Each v In Belts
Debug.Print v
Next
RigaChiusura:
Set c = Nothing
Set rng = Nothing
Set sh = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura
End Sub
Try Belts.Add c.Value, which will add the value in the cell to the collection as opposed to adding a reference to the range object to the collection. The value will still be available after the workbook is closed, as opposed to the reference which will no longer be available.
Array version
Don't know much about collections but I think arrays is the way to go.
Option Explicit
Public Belts As Variant 'Public Belts As Collection
Public Sub mCaricaBelts()
On Error GoTo RigaErrore
Dim wb As Workbook, wbn As String
Dim sh As Worksheet
Dim rng As Range
Dim c As Range, v As Variant
Dim lrw As Long
With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = _
"Sto caricato la tabella Fasce"
End With
wbn = "Listino.xlsx"
' If Not Belts Is Nothing Then
' Set Belts = Nothing
' End If
' Set Belts = New Collection
If AlreadyOpen(wbn) Then
Set wb = Workbooks(wbn)
Else
Set wb = Workbooks.Open("\\itcpifs01\license$\Listino.xlsx")
End If
Set rng = wb.Worksheets("dbRatesSTD").Range("C1")
Set rng = Range(rng, rng.End(xlToRight))
'Be careful, this is a horizontal array.
Belts = rng
' For Each c In rng
' Belts.Add c
' Next
' if I put the loop here, I can show results
For Each v In Belts
Debug.Print v
Next
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
' if I put the loop here, I can't show results, Error 424 Object required
For Each v In Belts
Debug.Print v
Next
RigaChiusura:
Set c = Nothing
Set rng = Nothing
Set sh = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura
End Sub
I have older Excel so I can only imagine what AlreadyOpen(wbn) means, but here's the old way for the complete If statement for your code:
'Check if Excel file is opened:
On Error Resume Next
Set wb = Workbooks(wbn) 'Workbook is opened.
If Err then 'Workbook is closed.
Set wb = Workbooks.Open("\\itcpifs01\license$\Listino.xlsx")
Err.Clear
End If
On Error GoTo RigaErrore 'Reactivate your 'first line error'.
There are no constants in your code. I would add this to the beginning of the code and make appropriate changes:
Const cStrTabella as String = "Sto caricato la tabella Fasce"
Const cStrWbn as String = "Listino.xlsx"
Const cStrWbp as String = "\\itcpifs01\license$\Listino.xlsx"
Const cStrWs as String = "dbRatesSTD"
Const cStrAddress as String = "C1"
Now it's much easier to change stuff and for someone else to modify it for a test and you can much faster get an answer for a problem.

ListObjects creation - late binding - From Access to Excel

I want to create a table after dropping the data in to a worksheet.
The following code drop a query result from Access to Excel. The code works fine up to "xlSheet.Range("$A$1:$U$2").Select" but failed to create the table. Can you help me?
Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding
Sub testExport()
Dim QryName As String
QryName = "BOM_REPORT_UNION"
ExportToExcelUsingQryName (QryName)
End Sub
Sub ExportToExcelUsingQryName(QueryName As String)
On Error GoTo SubError
'Late Binding
Set xlApp = CreateObject("Excel.Application")
'Late Binding end
Dim SQL As String
Dim i As Integer
'Show user work is being performed
DoCmd.Hourglass (True)
'Get the SQL for the queryname and Execute query and populate recordset
SQL = CurrentDb.QueryDefs(QueryName).SQL
Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rsBOMTopDown.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'Set column heading from recordset
SetColumnHeadingFromRecordset
'Copy data from recordset to Worksheet
xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown
'Create Table
xlSheet.Range("$A$1:$U$2").Select
'Set xlTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown" ' error 424 - Object Required
'Set xlTable = xlBook.xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown" ' error 424 - Object Required
Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes) ' error 5 invalid procedure call or argument
'Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown"
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rsBOMTopDown.Close
Set rsBOMTopDown = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Sub SetColumnHeadingFromRecordset() '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
For cols = 0 To rsBOMTopDown.Fields.count - 1
xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
Next
End Sub
The proposal from YowE3K did solve my issued. Thank for the help
Here the new code
Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding
'XlListObjectSourceType Enumeration (Excel) for late Binding
'Info: https://msdn.microsoft.com/en-us/library/office/ff820815.aspx
'-------------------------------------------------------------------
Public Const gclxlSrcRange As Long = 1 'Range
Sub testExport()
Dim QryName As String
QryName = "BOM_REPORT_UNION"
ExportToExcelUsingQryName (QryName)
End Sub
Sub ExportToExcelUsingQryName(QueryName As String)
On Error GoTo SubError
'Late Binding
Set xlApp = CreateObject("Excel.Application")
'Late Binding end
Dim SQL As String
Dim i As Integer
'Show user work is being performed
DoCmd.Hourglass (True)
'Get the SQL for the queryname and Execute query and populate recordset
SQL = CurrentDb.QueryDefs(QueryName).SQL
Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rsBOMTopDown.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'Set column heading from recordset
SetColumnHeadingFromRecordset
'Copy data from recordset to Worksheet
xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown
'Create Table
xlSheet.Range("$A$1:$U$2").Select
Set xlTable = xlSheet.ListObjects.Add(gclxlSrcRange, xlApp.Selection, , xlYes)
xlTable.Name = "tblBOMTopDown"
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rsBOMTopDown.Close
Set rsBOMTopDown = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Sub SetColumnHeadingFromRecordset() '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
For cols = 0 To rsBOMTopDown.Fields.count - 1
xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
Next
End Sub

Need some advice on how to stream line ACCESS/EXCEL VBA

I wrote this Access/VBA program. It works but only when I am not running other applications or few users are in the database. I need some ideas on streamlining the code. So it is not so system intensive. The program basically allows a user to pick a folder and then combines all worksheets in that folder in one excel document. My current idea is just to tell users to close all excel files when trying to run the program. Please Help:
Sub Excel_open()
Dim myXL As Excel.Application
Dim myXLS As Excel.Workbook
Const errExcelNotRunning = 429
On Error GoTo HandleIt
Set myXL = GetObject(, "Excel.application")
myXL.Visible = True
Set myXLS = myXL.Workbooks.Add
Call CombineWorkbooks(myXL)
HandleIt:
If Err.Number = errExcelNotRunning Then
Set myXL = CreateObject("Excel.Application")
Err.Clear
Resume Next
End If
End Sub
Sub CombineWorkbooks(myXL)
'Macro that combines the files into one folder
myXL.AskToUpdateLinks = False
myXL.DisplayAlerts = False
Dim CurFile As String, dirloc As String, strNamesheet As String
Dim DestWB As Workbook
Dim ws As Object ' allows for diffrent sheet types
'Add select the director function
dirloc = GetFolderName & "\" 'location of files not working want to select the file only
CurFile = Dir(dirloc & "*.xls*")
myXL.ScreenUpdating = False
myXL.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=dirloc & CurFile, ReadOnly:=True)
'need to change a name active name is not doing it
CurFile = Left(CurFile, 4) ' This is no longer 29
'CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29)
For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
' Use the name to give the sheet a name
strNamesheet = Left((ws.Name), 25) & ";"
If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = strNamesheet & CurFile ' & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If
Next
OrigWB.Close SaveChanges:=False
CurFile = Dir
Loop
myXL.DisplayAlerts = False
DestWB.Sheets(1).Delete
myXL.DisplayAlerts = True
myXL.ScreenUpdating = True
myXL.EnableEvents = True
Set DestWB = Nothing
Call Delete_empty_Sheets(myXL)
Call Sort_Active_Book
MsgBox "Done"
'Call Xcombine_the_Matching
End Sub
Sub Delete_empty_Sheets(myXL)
'goes through all sheets and deletes
Reset_the_search:
For Each wsElement In Worksheets
If wsElement.Range("A2") = "" And wsElement.Range("B2") = "" Then
myXL.DisplayAlerts = False
wsElement.Delete
GoTo Reset_the_search
myXL.DisplayAlerts = True
End If
Next wsElement
End Sub
Sub Xcombine_the_Matching()
'I think I can make the order work
'change and transpose the array
Dim varStart As Variant
Dim wsCompare As Worksheet
Dim strMatch As String
'Dim varCompare As Variant
Dim strVareince As String
Dim strCurrentName As String
'you need to build a loop to solve this problem
For Each wsCompare In Worksheets
strVareince = Add_Array(Application.Transpose(wsCompare.Range("A1:Z1")))
For Each wsNompare In Worksheets
If wsNompare.Name <> strCurrentName Then
If strVareince = Add_Array(Application.Transpose(wsNompare.Range("A1:Z1"))) Then
MsgBox ("Matched with worksheet " & wsNompare.Name)
End If
End If
Next
Next
End Sub
Function array_to_string(x) As String
For Z = 1 To 26
array_to_string = array_to_string & x(Z, 1) & ";"
Next Z
End Function
Function GetFolderName(Optional OpenAt As String) As String
'Allows you to select the folder director that you want to combine
Dim lCount As Long
GetFolderName = vbNullString
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Show
For lCount = 1 To .SelectedItems.Count
GetFolderName = .SelectedItems(lCount)
Next lCount
End With
End Function
Function Add_Array(x) As String
'turns an excel document
For d = 1 To UBound(x)
Add_Array = Add_Array & x(d, 1)
Next d
End Function
Sub Read_data()
'this the
End Sub
Sub Sort_Active_Book()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub
You are passing your Excel Application object into your subroutines, but not using it fully, neither are you explicitly referencing the libraries:
Sub CombineWorkbooks(myXL)
Dim DestWB As Excel.Workbook ' <<<
Set DestWB = myXL.Workbooks.Add(xlWorksheet) ' <<<
End Sub
Run through your code and fix all of these first, then test & supply more feedback on what the precise symptoms of the problems are.

How to close all active .xls files in vb6

I've tried something similar to this:
Set kitap = CreateObject("Excel.Application")
If IsXlsOpen() = True Then
kitap.Application.Quit
End If
.. but didnt work out so I neeed to find how to close all excel files before starting my program in vb6
EDIT: Full code here:
Dim i As Integer
Dim kitap As Object
Dim strcnn As String
Dim cnn As New ADODB.Connection
Dim Cmd As New ADODB.Command
Dim rs As New ADODB.Recordset
Private Sub Form_Load()
strcnn = "myconn"
cnn.Open strcnn
Cmd.ActiveConnection = cnn
End Sub
Public Function dotdate(ByRef elem) As String
Dim day, month, year As String
year = Right(elem, 4)
month = Mid(elem, Len(elem) - 5, 2)
day = Mid(elem, 1, Len(elem) - 6)
If Len(day) = 1 Then
day = "0" & day
End If
dotdate = day & "." & month & "." & year
End Function
Public Function IsXlsOpen(wbName) As String
Dim xl As Excel.Application
IsXlsOpen = False
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
If Err.Number <> 0 Then Exit Function
xl.Workbooks(wbName).Activate
If Err.Number = 0 Then IsXlsOpen= True
End Function
Private Sub Command1_Click()
Dim i As Integer
Dim cek As String
Set kitap = CreateObject("Excel.Application")
If IsXlsOpen("my.xls") = True Then
kitap.Application.Quit
End If
kitap.Workbooks.Add
cek = "Select * From blabla"
rs.Open cek, cnn
If rs.EOF = True Then
Situation.Caption = "Situation : EOF"
Else
kitap.Cells(i + 1, 1).Value = "ID"
kitap.Cells(i + 1, 2).Value = "Caption"
kitap.Cells(i + 1, 3).Value = "Date"
i = i + 1
Do While Not rs.EOF
kitap.Cells(i + 1, 1).Value = rs.Fields("id")
kitap.Cells(i + 1, 2).Value = rs.Fields("capt")
kitap.Cells(i + 1, 3).Value = dotdate(rs.Fields("date"))
rs.MoveNext
i = i + 1
Loop
rs.Close
End If
kitap.ActiveWorkbook.SaveAs (App.Path & "\my.xls")
kitap.Application.Quit
Situation.Caption = "Situation : Excel Formatted Report Ready."
Exit Sub
err:
rs.Close
Situation.Caption = "Critical Error! : Connection error detected. Please reset action."
End Sub
While I'm more a vbscript and vba guy, a bit more info would help:
ie what is IsXlsOpen?
what is your full kitmap code, ie have you opened and closed workbooks?
do you have any other xl instances open (before or during your code)?.
this link often solves VBA issues, in fixing global references
Note that it is good practice to close/quit workbooks/instances and set them to Nothing, ie in Tushar's code
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
To save and close all workbooks, read more
Option Explicit
Sub CloseAndSaveOpenWorkbooks()
Dim Wkb As Workbook
With Application
.ScreenUpdating = False
' Loop through the workbooks collection
For Each Wkb In Workbooks
With Wkb
' if the book is read-only
' don't save but close
If Not Wkb.ReadOnly Then
.Save
End If
' We save this workbook, but we don't close it
' because we will quit Excel at the end,
' Closing here leaves the app running, but no books
If .Name <> ThisWorkbook.Name Then
.Close
End If
End With
Next Wkb
.ScreenUpdating = True
.Quit 'Quit Excel
End With
End Sub

Resources