I had this code working and after I put code in to automatically save the workbook on close I am getting this error.
This is the structure. I am autoprocessing emails I receive using a rule in outlook. The rule searches for new mail with a certain subject, moves it to a new folder, and runs a macro in outlook to copy the data from the email body to an excel file. The Excel file has an auto_open macro that appends the new data from each email to an access database, moves the data then to a new sheet, saves the workbook, and closes the file.
So when Outlook is processing the email it stops on this line:
Set xlSheet = xlWB.Sheets(1)
Full code:
Outlook
Option Explicit
Sub ProcessNewExpNote(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\ProcessedReplies.xlsm" 'the path of the workbook
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets(1)
'Process the message record
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Confirm Resource's Full Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Confirm Resource's SOEID:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Extending (Yes/No):") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "New End Date (or confirm current - mm/dd/yyyy):") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "GOC (if extending):") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "In Forecast (Yes/No):") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Manager Approved (Yes/No):") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
xlSheet.Range("I" & rCount) = olItem.SenderName
xlSheet.Range("J" & rCount) = Date
Next i
xlWB.Close
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Excel code in workbook:
Private Sub Workbook_Open()
If Worksheets("data").Range("C2").Value = "" Then
Application.Wait (Now + TimeValue("0:00:03"))
End If
Call Export
End Sub
Excel Code in module:
Option Explicit
Sub Export()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim resSOEID, resExt, resNewDate, newGOC, forecastConf, manAppConf, confFrom, confReceived As String
Dim NextRow As String
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("archived")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("data")
Dim iRow As Integer
iRow = 1
Application.DisplayAlerts = False
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\DB.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "Actions", cn, adOpenKeyset, adLockOptimistic, adCmdTable
Range("C2").Activate ' row 1 contains column headings
Do While Not IsEmpty(ActiveCell)
resSOEID = ActiveCell.Value
resExt = ActiveCell.Offset(0, 1).Value
resNewDate = ActiveCell.Offset(0, 2).Value
newGOC = ActiveCell.Offset(0, 3).Value
forecastConf = ActiveCell.Offset(0, 4).Value
manAppConf = ActiveCell.Offset(0, 5).Value
confFrom = ActiveCell.Offset(0, 6).Value
confReceived = ActiveCell.Offset(0, 7).Value
rs.Filter = "SOEID='" & resSOEID & "'"
If rs.EOF Then
Debug.Print "No existing record..."
Else
Debug.Print "Existing record found..."
End If
rs("Date of Confirmation").Value = confReceived
rs("Manager Approval").Value = manAppConf
rs("In Forecast").Value = forecastConf
rs("Extending").Value = resExt
rs("New Extension Date").Value = resNewDate
rs("New GOC").Value = newGOC
rs("Received From").Value = confFrom
rs.Update
Debug.Print "...record update complete."
ActiveCell.Offset(1, 0).Activate ' next cell down
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
ws2.Activate
Do While ws2.Cells(iRow, 3) <> ""
iRow = iRow + 1
Loop
ws.Activate
ws.Range("B2:J2").Select
ws.Range("B2:J2").Copy
ws2.Activate
NextRow = ws2.Cells(iRow, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ws2.Range(NextRow & ":J" & iRow).PasteSpecial
ws.Activate
ws.Range("B2:J100").ClearContents
If iRow > 1000 Then
ws2.Activate
ws2.Range("B2:J1001").ClearContents
End If
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
Bookmarks