S
Steven Britton via AccessMonster.com
I have a function that export a spreadsheet through TransferSpreadsheet,
after I export the sheet I go out and pretty it up so that when the user
opens it the formatting is done for them.
The problem that I have is that after the export, Excel remains open as a
process in the task manager - However this process will terminate when I
close the Access database. I have some easy fixes in mind, but wanted to
refer to the masses first to see if anyone else has experienced this and if
there is a fix out there.
Thanks
-Steve
Option Compare Database
Option Explicit
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strPath As String, j As String, k As String
Dim myDate As String, mySource As String
Dim strPartNumUp As String, strPartNumDown As String
Dim End_Row As Long, r As Long
Dim xlsApp As Object, wkbTemp As Object
Function SendInvStsRpttoExcel()
On Error Resume Next
DoCmd.SetWarnings False
Set db = CurrentDb()
'Checks for export directory
If Len(Dir("C:\My Documents", vbDirectory)) = 0 Then
' Directory doesn't exist. Create It
MkDir ("C:\My Documents")
End If
myDate = Format(Date, "mm-dd-yy")
mySource = "Inventory Status"
'Naming of file
strPath = "C:\My Documents\" & myDate & " " & mySource & ".xls"
'If file with today's date exist delete it - Used for possible updated
report later in the day
If Len(Dir(strPath)) > 0 Then
Kill strPath
End If
'Delete Old Export Table
db.Execute "DELETE FROM tblInvStsRpt;"
'Make New Export Table
DoCmd.OpenQuery "qryAppendInvStsRpt"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"tblInvStsRpt", strPath
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False
xlsApp.UserControl = True
Set wkbTemp = xlsApp.Workbooks.Open(strPath)
xlsApp.ActiveWindow.Zoom = 85
'Delete AutoNumbers
xlsApp.Columns("A:A").Select
xlsApp.Selection.Delete Shift:=xlToLeft
xlsApp.Range("A1").Select
xlsApp.Selection.End(xlDown).Select
'Find end of file
End_Row = ActiveCell.Row
'r = 2 to skip header row
r = 2
Do Until r > End_Row
strPartNumUp = ActiveSheet.Cells(r, 1).Value
strPartNumDown = ActiveSheet.Cells(r + 1, 1).Value
j = Empty
k = Empty
If strPartNumUp = strPartNumDown Then
Do Until j <> k
'Used in formating report for readabilty - Removes Part
Number if Mulit PO's
j = strPartNumUp
k = ActiveSheet.Cells(r + 1, 1).Value
If j = k Then
'Make Lines between Parts
Range("A" & r + 1 & ":" & "D" & r + 1).Select
xlsApp.Selection.ClearContents
Else: Exit Do
End If
r = r + 1
Loop
'Make Lines between Parts
Range("A" & r - 1 & ":" & "I" & r - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
ElseIf strPartNumUp <> strPartNumDown Then
'Make Lines between Parts
Range("A" & r & ":" & "I" & r).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
r = r + 1
End If
Loop
'This is conditional formating if the Inv_Qty is equal to zero
'and there are no current PO's outstanding
xlsApp.Columns("D
").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Columns("E:E").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Range("J2").Select
xlsApp.ActiveCell.FormulaR1C1 = "=IF(AND(RC[-6]=0,RC[-5]=""None""),1,0)"
xlsApp.Range(Selection, Selection.End(xlDown)).Select
xlsApp.Selection.FillDown
xlsApp.Cells.Select
xlsApp.Cells.EntireColumn.AutoFit
ActiveWorkbook.Save
wkbTemp.Save
wkbTemp.Close False
Set wkbTemp = Nothing
xlsApp.Quit
Set xlsApp = Nothing
DoCmd.SetWarnings True
End Function
after I export the sheet I go out and pretty it up so that when the user
opens it the formatting is done for them.
The problem that I have is that after the export, Excel remains open as a
process in the task manager - However this process will terminate when I
close the Access database. I have some easy fixes in mind, but wanted to
refer to the masses first to see if anyone else has experienced this and if
there is a fix out there.
Thanks
-Steve
Option Compare Database
Option Explicit
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strPath As String, j As String, k As String
Dim myDate As String, mySource As String
Dim strPartNumUp As String, strPartNumDown As String
Dim End_Row As Long, r As Long
Dim xlsApp As Object, wkbTemp As Object
Function SendInvStsRpttoExcel()
On Error Resume Next
DoCmd.SetWarnings False
Set db = CurrentDb()
'Checks for export directory
If Len(Dir("C:\My Documents", vbDirectory)) = 0 Then
' Directory doesn't exist. Create It
MkDir ("C:\My Documents")
End If
myDate = Format(Date, "mm-dd-yy")
mySource = "Inventory Status"
'Naming of file
strPath = "C:\My Documents\" & myDate & " " & mySource & ".xls"
'If file with today's date exist delete it - Used for possible updated
report later in the day
If Len(Dir(strPath)) > 0 Then
Kill strPath
End If
'Delete Old Export Table
db.Execute "DELETE FROM tblInvStsRpt;"
'Make New Export Table
DoCmd.OpenQuery "qryAppendInvStsRpt"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"tblInvStsRpt", strPath
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False
xlsApp.UserControl = True
Set wkbTemp = xlsApp.Workbooks.Open(strPath)
xlsApp.ActiveWindow.Zoom = 85
'Delete AutoNumbers
xlsApp.Columns("A:A").Select
xlsApp.Selection.Delete Shift:=xlToLeft
xlsApp.Range("A1").Select
xlsApp.Selection.End(xlDown).Select
'Find end of file
End_Row = ActiveCell.Row
'r = 2 to skip header row
r = 2
Do Until r > End_Row
strPartNumUp = ActiveSheet.Cells(r, 1).Value
strPartNumDown = ActiveSheet.Cells(r + 1, 1).Value
j = Empty
k = Empty
If strPartNumUp = strPartNumDown Then
Do Until j <> k
'Used in formating report for readabilty - Removes Part
Number if Mulit PO's
j = strPartNumUp
k = ActiveSheet.Cells(r + 1, 1).Value
If j = k Then
'Make Lines between Parts
Range("A" & r + 1 & ":" & "D" & r + 1).Select
xlsApp.Selection.ClearContents
Else: Exit Do
End If
r = r + 1
Loop
'Make Lines between Parts
Range("A" & r - 1 & ":" & "I" & r - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
ElseIf strPartNumUp <> strPartNumDown Then
'Make Lines between Parts
Range("A" & r & ":" & "I" & r).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
r = r + 1
End If
Loop
'This is conditional formating if the Inv_Qty is equal to zero
'and there are no current PO's outstanding
xlsApp.Columns("D
").SelectxlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Columns("E:E").Select
xlsApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=
$J1=1"
xlsApp.Selection.FormatConditions(1).Interior.ColorIndex = 40
xlsApp.Range("J2").Select
xlsApp.ActiveCell.FormulaR1C1 = "=IF(AND(RC[-6]=0,RC[-5]=""None""),1,0)"
xlsApp.Range(Selection, Selection.End(xlDown)).Select
xlsApp.Selection.FillDown
xlsApp.Cells.Select
xlsApp.Cells.EntireColumn.AutoFit
ActiveWorkbook.Save
wkbTemp.Save
wkbTemp.Close False
Set wkbTemp = Nothing
xlsApp.Quit
Set xlsApp = Nothing
DoCmd.SetWarnings True
End Function