Hi!
I have a form in Access with a button with the code:
Private Sub cmdPrintToWord_Click()
Dim strSelect As String
Dim appWord As Word.Application
Dim appExcel As Excel.Application
Dim doc As Word.Document
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim rs, rst, rstTipOP, rstTipCO As ADODB.Recordset
Dim r, rez As Boolean
Dim lngCounter, i, j, ii, jj As Integer
Dim perTerminat, elemTablou(1 To 9) As Variant
Dim luna, OldElem, CurentElem, zile, strSelect1, strSelect2 As String
Me!CboLuna.SetFocus
If Me!CboLuna.Text = "" Then
r = MsgBox("Select month!", vbExclamation, "Attention")
Exit Sub
End If
luna = "Month(Operatii.Perioada_start)"
strSelect = "SELECT Operatii.Nume, Operatii.Initiala_tatalui, Operatii.Prenume, Operatii.Perioada_start, Operatii.Perioada_stop, Operatii.Nr_zile_concediu, FROM Operatii WHERE (((" & luna & ")=" & Me!CboLuna.Value & ")) GROUP BY Operatii.Nume;"
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear
'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set appWord = New Word.Application
End If
'Set appExcel object variable to running instance of Excel.
Set appExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
'If Excel isn't open, create a new instance of Excel.
Set appExcel = New Excel.Application
End If
'Populate recordset object.
Set rs = New ADODB.Recordset
rs.Open strSelect, "Myconn", adOpenKeyset, adLockOptimistic
'first document
If rs.RecordCount > 0 Then
DoCmd.Hourglass True
r = MsgBox("Pentru luna ' " & Me!CboLuna.Text & " ' au fost gasite " & rs.RecordCount & " inregistrari.", vbInformation, "Info")
rs.MoveFirst
Set doc = appWord.Documents.Open("C:\tabele_situatie_lunara_concedii.doc", , True)
lngCounter = 1
i = 1
j = 1
OldElem = rs!Tip_concediu
For lngCounter = 1 To rs.RecordCount
CurentElem = rs!Tip_concediu
If CurentElem <> OldElem Then
i = i + 1
j = 1
End If
With doc
.FormFields("fldDescriere" & i).Result = rs!Tip_concediu
.FormFields("fldLuna" & i).Result = Me!CboLuna.Text
End With
With doc.Tables(i)
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Nume & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Initiala_tatalui & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Prenume
End With
OldElem = CurentElem
rs.MoveNext
If lngCounter < rs.RecordCount Then
If OldElem = rs!Tip_concediu Then
doc.Tables(i).Rows.Add
j = j + 1
End If
End If
Next lngCounter
doc.SaveAs "C:\tabele_situatie_lunara_concedii_" & Me!CboLuna.Text & ".doc", wdFormatDocument
doc.Close
'*****************************second document
Set doc = appWord.Documents.Open("C:\situatie_lunara_concedii.doc", , True)
rs.MoveFirst
lngCounter = 1
i = 1
j = 1
OldElem = rs!Tip_concediu
For lngCounter = 1 To rs.RecordCount
CurentElem = rs!Tip_concediu
If CurentElem <> OldElem Then
i = i + 1
j = 1
End If
With doc
.FormFields("fldDescriere" & i).Result = rs!Tip_concediu
.FormFields("fldLuna" & i).Result = Me!CboLuna.Text
End With
With doc.Tables(i)
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Nume & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Initiala_tatalui & " "
End With
OldElem = CurentElem
rs.MoveNext
If lngCounter < rs.RecordCount Then
If OldElem = rs!Tip_concediu Then
doc.Tables(i).Rows.Add
j = j + 1
End If
End If
Next lngCounter
If i <= 9 Then
strSelect1 = "SELECT DISTINCT Operatii.Tip_concediu FROM Operatii WHERE (((" & luna & ")=" & Me!CboLuna.Value & "));"
strSelect2 = "SELECT * FROM TipConcediu ;"
'Populate recordset object.
Set rstTipOP = New ADODB.Recordset
Set rstTipCO = New ADODB.Recordset
rstTipOP.Open strSelect1, "Myconn", adOpenKeyset, adLockOptimistic
rstTipCO.Open strSelect2, "Myconn", adOpenKeyset, adLockOptimistic
rstTipOP.MoveFirst
rstTipCO.MoveFirst
i = i + 1
jj = i
Do While Not rstTipCO.EOF
If rstTipCO!Descriere = rstTipOP!Tip_concediu Then
rstTipCO.MoveNext
rstTipOP.MoveFirst
Else
If Not rstTipOP.EOF Then
rstTipOP.MoveNext
If rstTipOP.EOF Then
elemTablou(i) = rstTipCO!Descriere
i = i + 1
rstTipOP.MoveFirst
rstTipCO.MoveNext
End If
End If
End If
Loop
For ii = 1 To (9 - (jj - 1))
With doc
.FormFields("fldDescriere" & jj).Result = elemTablou(jj)
.FormFields("fldLuna" & jj).Result = Me!CboLuna.Text
End With
With doc.Tables(jj)
.Cell(Row:=ii + 1, Column:=3).Range.InsertAfter Text:="No."
.Range.Select
With Selection
.Range.Paragraphs.Alignment = wdAlignParagraphRight
End With
End With
jj = jj + 1
Next ii
End If
doc.SaveAs "C:\situatie_lunara_concedii_" & Me!CboLuna.Text & ".doc", wdFormatDocument
doc.Close
Set exlBook = appExcel.Workbooks.Open("C:\tabel.xls")
Set exlSheet = exlBook.Sheets("Sheet1")
exlSheet.[A1] = 56576767
'exlSheet.Cells.Find(What:="whatever", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select
exlBook.SaveAs ("C:\tabel_" & Me!CboLuna.Text & ".xls")
exlBook.Close False, "tabel.xls"
exlBook.Close False, "C:\tabel_" & Me!CboLuna.Text & ".xls"
appExcel.Quit
DoCmd.Hourglass False
MsgBox "Finished !"
'******************************************
Else
r = MsgBox("Uups ! No records !!", vbExclamation, "Error")
End If
appWord.Quit
Set doc = Nothing
Set appWord = Nothing
Set rs = Nothing
Set rst = Nothing
Set rstTipOP = Nothing
Set rstTipCO = Nothing
Set exlSheet = Nothing
Set exlBook = Nothing
Set appExcel = Nothing
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
The problem is at the final of my code... When I close the Excel application it closes but the process "excel.exe" remains active and I see it in task manager. When i try to open a .xls file , excel opens but don't load my file... I open the task manager, kill the process and now I can open .xls files. How to fix this problem in my code, to close excel? Any suggestions? Thank you for your time!
I have a form in Access with a button with the code:
Private Sub cmdPrintToWord_Click()
Dim strSelect As String
Dim appWord As Word.Application
Dim appExcel As Excel.Application
Dim doc As Word.Document
Dim exlBook As Excel.Workbook
Dim exlSheet As Excel.Worksheet
Dim rs, rst, rstTipOP, rstTipCO As ADODB.Recordset
Dim r, rez As Boolean
Dim lngCounter, i, j, ii, jj As Integer
Dim perTerminat, elemTablou(1 To 9) As Variant
Dim luna, OldElem, CurentElem, zile, strSelect1, strSelect2 As String
Me!CboLuna.SetFocus
If Me!CboLuna.Text = "" Then
r = MsgBox("Select month!", vbExclamation, "Attention")
Exit Sub
End If
luna = "Month(Operatii.Perioada_start)"
strSelect = "SELECT Operatii.Nume, Operatii.Initiala_tatalui, Operatii.Prenume, Operatii.Perioada_start, Operatii.Perioada_stop, Operatii.Nr_zile_concediu, FROM Operatii WHERE (((" & luna & ")=" & Me!CboLuna.Value & ")) GROUP BY Operatii.Nume;"
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear
'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set appWord = New Word.Application
End If
'Set appExcel object variable to running instance of Excel.
Set appExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
'If Excel isn't open, create a new instance of Excel.
Set appExcel = New Excel.Application
End If
'Populate recordset object.
Set rs = New ADODB.Recordset
rs.Open strSelect, "Myconn", adOpenKeyset, adLockOptimistic
'first document
If rs.RecordCount > 0 Then
DoCmd.Hourglass True
r = MsgBox("Pentru luna ' " & Me!CboLuna.Text & " ' au fost gasite " & rs.RecordCount & " inregistrari.", vbInformation, "Info")
rs.MoveFirst
Set doc = appWord.Documents.Open("C:\tabele_situatie_lunara_concedii.doc", , True)
lngCounter = 1
i = 1
j = 1
OldElem = rs!Tip_concediu
For lngCounter = 1 To rs.RecordCount
CurentElem = rs!Tip_concediu
If CurentElem <> OldElem Then
i = i + 1
j = 1
End If
With doc
.FormFields("fldDescriere" & i).Result = rs!Tip_concediu
.FormFields("fldLuna" & i).Result = Me!CboLuna.Text
End With
With doc.Tables(i)
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Nume & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Initiala_tatalui & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Prenume
End With
OldElem = CurentElem
rs.MoveNext
If lngCounter < rs.RecordCount Then
If OldElem = rs!Tip_concediu Then
doc.Tables(i).Rows.Add
j = j + 1
End If
End If
Next lngCounter
doc.SaveAs "C:\tabele_situatie_lunara_concedii_" & Me!CboLuna.Text & ".doc", wdFormatDocument
doc.Close
'*****************************second document
Set doc = appWord.Documents.Open("C:\situatie_lunara_concedii.doc", , True)
rs.MoveFirst
lngCounter = 1
i = 1
j = 1
OldElem = rs!Tip_concediu
For lngCounter = 1 To rs.RecordCount
CurentElem = rs!Tip_concediu
If CurentElem <> OldElem Then
i = i + 1
j = 1
End If
With doc
.FormFields("fldDescriere" & i).Result = rs!Tip_concediu
.FormFields("fldLuna" & i).Result = Me!CboLuna.Text
End With
With doc.Tables(i)
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Nume & " "
.Cell(Row:=lngCounter + 1, Column:=3).Range.InsertAfter Text:=rs!Initiala_tatalui & " "
End With
OldElem = CurentElem
rs.MoveNext
If lngCounter < rs.RecordCount Then
If OldElem = rs!Tip_concediu Then
doc.Tables(i).Rows.Add
j = j + 1
End If
End If
Next lngCounter
If i <= 9 Then
strSelect1 = "SELECT DISTINCT Operatii.Tip_concediu FROM Operatii WHERE (((" & luna & ")=" & Me!CboLuna.Value & "));"
strSelect2 = "SELECT * FROM TipConcediu ;"
'Populate recordset object.
Set rstTipOP = New ADODB.Recordset
Set rstTipCO = New ADODB.Recordset
rstTipOP.Open strSelect1, "Myconn", adOpenKeyset, adLockOptimistic
rstTipCO.Open strSelect2, "Myconn", adOpenKeyset, adLockOptimistic
rstTipOP.MoveFirst
rstTipCO.MoveFirst
i = i + 1
jj = i
Do While Not rstTipCO.EOF
If rstTipCO!Descriere = rstTipOP!Tip_concediu Then
rstTipCO.MoveNext
rstTipOP.MoveFirst
Else
If Not rstTipOP.EOF Then
rstTipOP.MoveNext
If rstTipOP.EOF Then
elemTablou(i) = rstTipCO!Descriere
i = i + 1
rstTipOP.MoveFirst
rstTipCO.MoveNext
End If
End If
End If
Loop
For ii = 1 To (9 - (jj - 1))
With doc
.FormFields("fldDescriere" & jj).Result = elemTablou(jj)
.FormFields("fldLuna" & jj).Result = Me!CboLuna.Text
End With
With doc.Tables(jj)
.Cell(Row:=ii + 1, Column:=3).Range.InsertAfter Text:="No."
.Range.Select
With Selection
.Range.Paragraphs.Alignment = wdAlignParagraphRight
End With
End With
jj = jj + 1
Next ii
End If
doc.SaveAs "C:\situatie_lunara_concedii_" & Me!CboLuna.Text & ".doc", wdFormatDocument
doc.Close
Set exlBook = appExcel.Workbooks.Open("C:\tabel.xls")
Set exlSheet = exlBook.Sheets("Sheet1")
exlSheet.[A1] = 56576767
'exlSheet.Cells.Find(What:="whatever", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select
exlBook.SaveAs ("C:\tabel_" & Me!CboLuna.Text & ".xls")
exlBook.Close False, "tabel.xls"
exlBook.Close False, "C:\tabel_" & Me!CboLuna.Text & ".xls"
appExcel.Quit
DoCmd.Hourglass False
MsgBox "Finished !"
'******************************************
Else
r = MsgBox("Uups ! No records !!", vbExclamation, "Error")
End If
appWord.Quit
Set doc = Nothing
Set appWord = Nothing
Set rs = Nothing
Set rst = Nothing
Set rstTipOP = Nothing
Set rstTipCO = Nothing
Set exlSheet = Nothing
Set exlBook = Nothing
Set appExcel = Nothing
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
The problem is at the final of my code... When I close the Excel application it closes but the process "excel.exe" remains active and I see it in task manager. When i try to open a .xls file , excel opens but don't load my file... I open the task manager, kill the process and now I can open .xls files. How to fix this problem in my code, to close excel? Any suggestions? Thank you for your time!
