Export Report Tabs to MS Excel

[system]

The following code will process a document and export each individual report tab to MS Excel. It is currently done in the “AfterRefresh” event but could be called as a subroutine instead.

Original Author: Unknown
Original Author Comments:

Attached is a report based upon the Island Resorts Marketing database which downloads multiple report tabs to a multiple-report tab Excel spreadsheet. It then sends the Excel spreadsheet to a user through Outlook.

To test this example:

• open the report and change the MailTo line of code so you are
  e-mailing the report to yourself.

• Change the path to point to a directory your PC has access to.

  Note: I was not able to get the example to work if I used a letter before the path (like c:\apps\businessobjects\userdocs) so leave the letter off when you type the path (\apps\businessobjects\userdocs).

• Refresh the report and then check your inbox to see if your e-mail has arrived.

• After you successfully send the spreadsheet to yourself by
  refreshing the report from Full Client, change the Path line of code to be
  the path of your Broadcast Agent server.

• Then schedule the report to be refreshed using BCA and wait for the spreadsheet to arrive in your inbox.

  Note 1: Outlook needs to be installed on your BCA before you try this.

  Note 2: There may be a time lag between when the report is
  refreshed and when Outlook checks for new outgoing messages so it might take a while for your e-mail to arrive from the BCA (right now the time lag for us is 3 hours until I have someone on our server team modify whatever needs to be changed so Outlook checks more frequently)

Private Sub Document_AfterRefresh()

On Error GoTo error_handler

Dim Doc As Document
Dim Rep As Report
Dim i As Integer
Dim ExcelDoc As String 'Stores the name of the Excel document to copy all report tabs to
Dim Path As String 'Stores the path in while the Excel files are created.
Dim MailTo As String 'Stores the name of the person who is to receive the report via e-mail

ExcelDoc = "ex_multi_tab" 'The name of the Excel document you plan to send to user(s) through e-mail.
Path = "\\ServerOrFolderName\"  'The path on your PC that you wish to save the Excel document to.  Leave off the letter and just include the path.
'Path = "\\Server\FolderName"  'The path if you plan to scheduling this document on the Broadcast Agent server
MailTo = "Outlook UserName" ' Use this MailTo address if e-mailing an internal user who does not have access to the internet.
'MailTo = "username@company.com"  'Use this MailTo if e-mailing someone who has an internet address.

'Save report tabs as text files
Set Doc = ActiveDocument
For i = 1 To Doc.Reports.Count
  Set Rep = Doc.Reports.Item(i)
 If Dir(Path &amp; Rep.Name &amp; ".txt") <> " " Then
    Kill Path &amp; Rep.Name &amp; ".txt"
  End If
  Rep.ExportAsText (Path &amp; Rep.Name &amp; ".txt")
Next i

Set vbExcel = CreateObject("Excel.Application")
With vbExcel
'Create a new workbook to import text files into
  If Dir(Path &amp; ExcelDoc &amp; ".xls") <> " " Then
    Kill Path &amp; ExcelDoc &amp; ".xls"
  End If
  .Workbooks.Add
  .ActiveWorkbook.SaveAs Path &amp; ExcelDoc &amp; ".xls"
'Open source workbook, save as an Excel file, and import into destination Excel file.
For i = 1 To Doc.Reports.Count
  Set Rep = Doc.Reports.Item(i)
  .Workbooks.Open Path &amp; Rep.Name &amp; ".txt"
  If Dir(Path &amp; Rep.Name &amp; ".xls") <> " " Then
    Kill Path &amp; Rep.Name &amp; ".xls"
  End If
  .ActiveWorkbook.SaveAs Path &amp; Rep.Name &amp; ".xls"
  'Copy worksheets to the destination Excel document
    .Workbooks(Rep.Name &amp; ".xls").Sheets(Rep.Name).Move _
      Before:=.Workbooks(ExcelDoc &amp; ".xls").Sheets("Sheet1")
Next i
'Save workbooks
  '.Workbooks(ExcelDoc &amp; ".xls").Sheets("Sheet1").Delete
  '.Workbooks(ExcelDoc &amp; ".xls").Sheets("Sheet2").Delete
  '.Workbooks(ExcelDoc &amp; ".xls").Sheets("Sheet3").Delete
'Close both workbooks
  .ActiveWorkbook.Save
  Workbooks.Close
'Close Excel application object
  .Quit
End With
  'Release object variable to free memory
  Set vbExcel = Nothing

'Send Through Outlook

Set OlkApp = CreateObject("Outlook.Application")
Set NewMail = OlkApp.CreateItem(olMailItem)
Set Attachments = NewMail.Attachments

Attachments.Add (Path &amp; ExcelDoc &amp; ".xls")

With NewMail
.To = MailTo
.Body = "Your multiple-tab report is attached and available for viewing in Excel."
.Subject = "Sample - download multiple tab report and send via email"
.Importance = 1
.Send
End With
Set OlkApp = Nothing

'Delete files used to create the e-mail attachment
  Kill Path &amp; ExcelDoc &amp; ".xls"
  For i = 1 To Doc.Reports.Count
    Set Rep = Doc.Reports.Item(i)
    Kill Path &amp; Rep.Name &amp; ".txt"
    Kill Path &amp; Rep.Name &amp; ".xls"
  Next i

'Export Completed

Exit Sub

error_handler:
If Err.Number = 53 Then Resume Next
  MsgBox Err.Number &amp; " - " &amp; Err.Description
  Workbooks.Close
  vbExcel.Quit
  Set vbExcel = Nothing
    Set OlkApp = Nothing

End Sub

Private Sub Document_BeforeSave(Cancel As Boolean)

End Sub

ExportExcelMail.zip (20.0 KB)

---

BOB Downloads (BOB member since 2003-05-05)