"Object variable or With block variable not set" issue

[Arleta]

Please I need your help for an issue I have with the following code. I used it to export each record of a table in a different excel file, then format it and at the end send it by email. Although it runs perfect for one time when is running the same procedure for the second record it stops at the point it has to do some underline and I got the following error message : "Object variable or With block variable not set" . Can someone advice why this is about?

The code I use is as below:

Private Sub Image25_Click()
'DoCmd.SetWarnings False

DoCmd.Echo False, "Running Program"
Dim qdf As DAO.QueryDef
Dim DBS As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim DisplayMsg As Boolean
Dim varTo As Variant
Dim stWhere As String
Dim ExcelFile As String
Dim ExcelWorksheet As String
Dim Ques As String
Dim QueryName As String
Dim objDB As Database


On Error GoTo Err_SendMessage

Set DBS = CurrentDb
Set qdf = DBS.QueryDefs("q_temp")

strSQL = "SELECT DISTINCT BRANCH, BranchDirector, GrTypo FROM tbl_MetavLog_SEND;"
Set rstMgr = DBS.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

Do While rstMgr.EOF = False

strMgr = DLookup("BRANCH", "T_BranchList", _
"BRANCH = " & rstMgr!BRANCH.Value)

strSQL = "SELECT * FROM tbl_MetavolesAllilografiasLog_SEND WHERE " & _
"BRANCH = " & rstMgr!BRANCH.Value & ";"


qdf.sql = strSQL
qdf.Close
' Replace C:\FolderName\ with actual path
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"q_temp", "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"


ExcelFile = "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"
ExcelWorksheet = "q_temp"
Ques = "C:\Users\DB.accdb"
QueryName = "q_temp"

Set objDB = OpenDatabase(Ques)

If Dir(ExcelFile) <> "" Then Kill ExcelFile

objDB.Execute "Select*Into[Excel 8.0;Database=" & ExcelFile & "].[" & ExcelWorksheet & "] From " & "[" & QueryName & "]"
objDB.Close
Set objDB = Nothing

Dim ObjExcel
Set ObjExcel = CreateObject("Excel.Application")
ObjExcel.Visible = True

ObjExcel.Workbooks.Open "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"

Set Objsheet = ObjExcel.ActiveWorkbook.Worksheets(1)

With Objsheet
.Rows("1:1").Font.Bold = True
.Rows("1:1").Font.Underline = xlUnderlineStyleSingle
.Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("A3:A34").Select
Selection.Font.ColorIndex = 3
Selection.Font.Bold = True
.Columns("A:CZ").Select
.Columns("A:CZ").EntireColumn.AutoFit
.Columns("A:CZ").HorizontalAlignment = xlCenter
.Columns("A:CZ").VerticalAlignment = xlCenter
End With

Dim LastRow As Long
Dim c As Integer
Dim i As Integer

'find the last used cell in Column "B" (Center)
LastRow = Objsheet.Range("B65536").End(xlUp).Row

'Add "TOTALS" text and formatting
Objsheet.Range("A" & LastRow + 1).Value = " "

'show the cell borders
With Objsheet.Range("A2:R" & LastRow + 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With ObjExcel.Selection.Font
.Name = "Calibri"
.Size = 10
End With


ObjExcel.ActiveWorkbook.Save
ObjExcel.ActiveWorkbook.Close
ObjExcel.Quit
DoCmd.Hourglass False

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
' Set the Subject, Body, and Importance of the message.
.Subject = rstMgr!BRANCH & "-" & rstMgr!GrTypo
.Body = Forms!t_EMAILBODY.Text5
.To = rstMgr!BranchDirector
'.Importance = olImportanceHigh 'High importance

Set objOutlookAttach = .Attachments.Add("D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls")
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next

.Display
Dim Response As Integer
Response = MsgBox(prompt:="To continue press 'Yes' For exit 'No'.", Buttons:=vbYesNo)
' if user selects yes, i would like to macro to continue running
If Response = vbNo Then
GoTo Exit_SendMessage

End If

End With

rstMgr.MoveNext
Loop

Exit_SendMessage:

Set qdf = Nothing
Set objOutlook = Nothing
rstMgr.Close
Set rstMgr = Nothing
DBS.Close
Set DBS = Nothing
Exit Sub

Err_SendMessage:
MsgBox Error$
Resume Exit_SendMessage

End Sub

 

[MarkK]

It fails at which line?

 

[boblarson]

Well, the first thing I see is that you shouldn't be creating an Excel Object on every pass of the code. Just create it once at the top and then quit it at the very end and set it to nothing. Don't do it over and over again.

 

[Arleta]

Thanks for ur reply! After some changes I think I'm close to the miracle. Going a step further and I've managed to create the excel files properly formatted but at the end the whold DB freezes and I have to close and reopen. Any suggestions?

Here is the code as it is now.


DoCmd.Echo False, "Running Program"

DoCmd.Hourglass True
Dim qdf As DAO.QueryDef
Dim DBS As DAO.Database
Dim rstMgr As DAO.Recordset
Dim strSQL As String, strTemp As String, strMgr As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim DisplayMsg As Boolean
Dim varTo As Variant
Dim stWhere As String
Dim ExcelFile As String
Dim ExcelWorksheet As String
Dim Ques As String
Dim QueryName As String
Dim objDB As Database
Dim ObjExcel
Set ObjExcel = CreateObject("Excel.Application")
ObjExcel.Visible = True


Set DBS = CurrentDb
Set qdf = DBS.QueryDefs("q_temp")

strSQL = "SELECT DISTINCT BRANCH, BranchDirector, GrTypo FROM tbl_MetavolesAllilografiasLog_SEND;"
Set rstMgr = DBS.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

Do While rstMgr.EOF = False

strMgr = DLookup("BRANCH", "T_BranchList", _
"BRANCH = " & rstMgr!BRANCH.Value)

strSQL = "SELECT * FROM tbl_MetavolesAllilografiasLog_SEND WHERE " & _
"BRANCH = " & rstMgr!BRANCH.Value & ";"


qdf.sql = strSQL
qdf.Close
' Replace C:\FolderName\ with actual path
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"q_temp", "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"


ExcelFile = "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"
ExcelWorksheet = "q_temp"
Ques = "C:\Users\DAILY AUDIT DB.accdb"
QueryName = "q_temp"

Set objDB = OpenDatabase(Ques)

If Dir(ExcelFile) <> "" Then Kill ExcelFile

objDB.Execute "Select*Into[Excel 8.0;Database=" & ExcelFile & "].[" & ExcelWorksheet & "] From " & "[" & QueryName & "]"
objDB.Close
Set objDB = Nothing



ObjExcel.Workbooks.Open "D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls"
Set Objsheet = ObjExcel.ActiveWorkbook.Worksheets(1)

With Objsheet
.Rows("1:1").Font.Bold = True
.Rows("1:1").Font.Underline = xlUnderlineStyleSingle
.Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Range("A3:A34").Select
Selection.Font.ColorIndex = 3
Selection.Font.Bold = True
.Columns("A:CZ").Select
.Columns("A:CZ").EntireColumn.AutoFit
.Columns("A:CZ").HorizontalAlignment = xlCenter
.Columns("A:CZ").VerticalAlignment = xlCenter
End With

Dim LastRow As Long
Dim c As Integer
Dim i As Integer

'find the last used cell in Column "B" (Center)
LastRow = Objsheet.Range("B65536").End(xlUp).Row

'Add "TOTALS" text and formatting
Objsheet.Range("A" & LastRow + 1).Value = " "

'show the cell borders
With Objsheet.Range("A2:R" & LastRow + 1).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With ObjExcel.Selection.Font
.Name = "Calibri"
.Size = 10
End With
ObjExcel.ActiveWorkbook.Save
ObjExcel.ActiveWorkbook.Close
ObjExcel.Quit
DoCmd.Hourglass False

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
' Set the Subject, Body, and Importance of the message.
.Subject = rstMgr!BRANCH & "-" & rstMgr!GrTypo
.Body = Forms!t_EMAILBODY.Text5
.To = rstMgr!BranchDirector
'.Importance = olImportanceHigh 'High importance

Set objOutlookAttach = .Attachments.Add("D:\DPROJECT\" & strMgr & "-" & Format(Now(), _
"ddMMMyyyy") & ".xls")
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next

.Display
Dim Response As Integer
Response = MsgBox(prompt:="To continue press 'Yes' For exit 'No'.", Buttons:=vbYesNo)
' if user selects yes, i would like to macro to continue running
If Response = vbNo Then
GoTo Exit_SendMessage

End If

End With

rstMgr.MoveNext
Loop

Exit_SendMessage:

Set qdf = Nothing
Set objOutlook = Nothing
rstMgr.Close
Set rstMgr = Nothing
DBS.Close
Set DBS = Nothing
Exit Sub

Err_SendMessage:
MsgBox Error$
Resume Exit_SendMessage


End Sub

 

[boblarson]

Yes, there is an obvious problem. Read this article from my website (don't worry it is short) and know that you have to tie ANY Excel code to the application object whether it be directly or via another object which has been instantiated from it (like a worksheet variable).

So, your code like this:

Selection.Insert Shift:=xlDown
Range("A1").Select

Will cause the problem. it should be

[COLOR=red]ObjExcel.[/COLOR]Selection.Insert Shift:=xlDown
[COLOR=red]Objsheet.[/COLOR]Range("A1").Select

Or if you have
With Objsheet

then you just need to add a period to the Range one.

 

[Arleta]

and YES !! It is working!! Thank you very very much. Very precious help

 

[boblarson]

and YES !! It is working!! Thank you very very much. Very precious help

Glad you got it working.

 

[Arleta]

I could never make it without your assistance. I'm reading this forum since 2005 even though I don't participate that much and I would like to say a BIG thanks to all this support you offer to people all over the world.