Here it is, it does a little more than just the Excel generation.
'------------------------------------------------------
' Macro to build PowerPlay Cubes
'------------------------------------------------------
' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Global strTodaysDate As String
Dim strCatalogueDirectory1 As String
Dim strCatalogueSmallName1 As String
Dim strCatalogueFileName1 As String
Dim strCatalogueClass1 As String
Dim strCataloguePassword1 As String
Dim strDatabaseUser1 As String
Dim strDatabasePassword1 As String
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LOG FILE DECLARE
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Global LogFile as Integer
Global ProcessFlag as Integer
Const LogFileIdentifier = "Audi-Daily-PDF-Sales_"
Const LogFilePath = "F:\IDSe42BI\Production\Macros\Logs\"
Declare Sub OpenLogFile()
Declare Sub WriteLogFile(logmsg$)
Declare Sub CloseLogFile()
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PDF FILE DECLARE
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Declare Function convertName (n$) As String
Declare Sub SaveReportAsPDF (catname$, reportname$, catclass$, catpassword$, databaseuser$, databasepassword$, savepdf$)
Declare Sub SavePowerPlayReportAsPDF (sourceName$, destPDFName$)
'--
Declare Sub SaveReportAsExl (catname$, reportname$, catclass$, catpassword$, databaseuser$, databasepassword$, saveExl$)
Dim objImpRep as Object
Dim objImpApp as Object
Dim objPDFPub as Object
Dim objExlPub as Object
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DEPARTMENT DECLARE
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Declare Sub ProcessDepartment (department$)
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' COMMAND DECLARE
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
Const NORMAL_PRIORITY_CLASS = &H20&
Const INFINITE = -1&
' Changed directory to postproduction for the Generate and Save Directory - RB 27032006
Const MacroName = "Audi-Daily-PDF-Sales.MAC"
Const CatalogueDir = "F:\IDSe42BI\Production\Audi\IDS\Hotfiles\"
Const ModelDir = "F:\IDSe42BI\Production\Audi\IDS\Powerplay Cubes\Models\"
Const TrnsDir = "C:\Program Files (x86)\Cognos\cer4\bin\"
Const PPBuildDir = "F:\IDSe42BI\Production\Audi\IDS\Powerplay Cubes\"
Const GenerateDir = "F:\IDSe42BI\Production\Audi\Generate\"
Const SaveDir = "F:\IDSe42BI\Production\Audi\"
Const DayDir = "Daily\"
Const ExclDir = "Excel\"
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PROCESS FOLDER DOCUMENTS DECLARE
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Declare Sub FolderReportsSaveAsPDF (catname$, catclass$, catpassword$, databaseuser$, databasepassword$, sourcefolder$, destinationfolder$)
Declare Sub FolderReportsSaveAsExl (catname$, catclass$, catpassword$, databaseuser$, databasepassword$, sourcefolder$, destinationfolder$)
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LOG FILE SUBROTINES
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'-------------------------------------------------------------------------------------
' create a log file name with the date appended to the LogFileIdentifier, ie filemmdd.LOG
'-------------------------------------------------------------------------------------
Sub OpenLogFile()
LogFile = FreeFile
Open LogFilePath & LogFileIdentifier & Format$( Now, "yymmdd_hhmm" ) & ".LOG" For Output as LogFile
End Sub
'-------------------------------------------------------------------------------------
' Write a message to the log file.
'-------------------------------------------------------------------------------------
Sub WriteLogFile(logmsg$)
Print #LogFile, Format(Now, "dmmmyy h:mm:ss") & " " & logmsg$
End Sub
'-------------------------------------------------------------------------------------
' Close the log file.
'-------------------------------------------------------------------------------------
Sub CloseLogFile()
Close LogFile
End Sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PDF FILE SUBROTINES
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function replaceWildcard(strS$, strWildcard$, strNow$) As String
Dim intWildPosition As Integer
Dim intLen As Integer
Dim intRightPosition As Integer
Dim newName1 As String
Dim newName2 As String
Dim newName3 As String
intWildPosition = InStr(strS$, strWildCard$)
If intWildPosition > 0 Then
intLen = Len(strS$)
newName1 = Left(strS$ ,intWildPosition - 1)
newName2 = Format$( Now, strNow$)
intRightPosition = intLen - intWildPosition - Len(strWildcard$) + 1
If intRightPosition > 0 Then
newName3 = Right(strS$ ,intRightPosition)
Else
newName3 = ""
End If
replaceWildcard = newName1 + newName2 + NewName3
Else
replaceWildcard = strS$
End If
End Function
Function convertName(n$) As String
Dim intDatePosition As Integer
Dim intLen As Integer
Dim intRightPosition As Integer
Dim newName As String
Dim newName1 As String
Dim newName2 As String
Dim newName3 As String
' Build Parameters required to generate a PDF from a Impromptu or Powerplay Report
' Define the Report
newName = n$
newName = replaceWildcard(newName, "&YEAR", "yyyy")
newName = replaceWildcard(newName, "&MONTH", "mmmm")
newName = replaceWildcard(newName, "&DAY", "dddd")
newName = replaceWildcard(newName, "&YY", "yy")
newName = replaceWildcard(newName, "&MM", "mm")
newName = replaceWildcard(newName, "&DD", "DD")
newName = replaceWildcard(newName, "&TIMESEC", "hhmmss")
newName = replaceWildcard(newName, "&TIME", "hhmm")
' Return the new name
convertName = newName
End Function
'-------------------------------------------------------------------------------------
' Save a Impromptu Report as a PDF File
'-------------------------------------------------------------------------------------
Sub SaveReportAsPDF (catname$, reportname$, catclass$, catpassword$, databaseuser$, databasepassword$, savepdf$)
ON ERROR resume next
WriteLogFile("Save Impromptu Report as PDF")
Set objImpApp = CreateObject("CognosImpromptu.Application")
' Open the Catalogue
WriteLogFile("Open Catalogue: " + catname$)
objImpApp.OpenCatalog catname$, catclass$, catpassword$, databaseuser$, databasepassword$
' Open the Report
WriteLogFile("Open Impromptu Report: " + reportname$)
Set objImpRep = objImpApp.OpenReport(reportname$)
strReportName = objImpRep.FullName
objImpRep.RetrieveAll
' Publish the Report in PDF
Set objPDFPub = objImpRep.PublishPDF
' Save the PDF
WriteLogFile("Save as PDF File: " + savepdf$)
objPDFPub.Publish savepdf$
objImpRep.CloseReport
objImpApp.CloseCatalog
objImpApp.Quit
Set objImpApp = Nothing
Set objImpRep = Nothing
Set objPDFPub = Nothing
End Sub
'-------------------------------------------------------------------------------------
' Save a Impromptu Report as a Excel with Format File
'-------------------------------------------------------------------------------------
Sub SaveReportAsExl (catname$, reportname$, catclass$, catpassword$, databaseuser$, databasepassword$, saveExl$)
Dim strErr as String
Dim ImpExcelRep as Object
ON ERROR resume next
WriteLogFile("Save Impromptu Report as Excel with Format")
Set objImpApp = CreateObject("CognosImpromptu.Application")
objImpApp.visible 0
objImpApp.UseQueryWarnings 0
' Open the Catalogue
WriteLogFile("Open Catalogue: " + catname$)
objImpApp.OpenCatalog catname$, catclass$, catpassword$, databaseuser$, databasepassword$
' Open the Report
WriteLogFile("Open Impromptu Report: " + reportname$)
Set objImpRep = objImpApp.OpenReport(reportname$)
strReportName = objImpRep.FullName
objImpRep.RetrieveAll
'Publish the Report in Excel with Format.
' Publish and Save the PDF
WriteLogFile("Save as Excel File: " + saveExl$)
' Save as Excel 2000 (More Resilient)
Set ImpExcelRep = objImpRep.PublishExcel
ImpExcelRep.Version 0
ImpExcelRep.ExportOptions 0
ImpExcelRep.Publish saveExl$
' Old Publish Method
'''objImpRep.ExportExcelWithFormat saveExl$
objImpRep.CloseReport
objImpApp.CloseCatalog
objImpApp.Quit
Set ImpExcelRep = Nothing
Set objImpApp = Nothing
Set objImpRep = Nothing
Set objPDFPub = Nothing
End sub
'-------------------------------------------------------------------------------------
' Save a Powerplay Report as a PDF File
'-------------------------------------------------------------------------------------
sub SavePowerPlayReportAsPDF(sourceName$, destPDFName$)
Dim PPRep as Object
Dim objPDF As Object
' Open the Powerplay Cube
WriteLogFile("Save Powerplay Report as PDF")
Set PPRep = CreateObject("PowerPlay.Report")
WriteLogFile("Open Powerplay Report: " + sourceName$)
PPRep.Open sourceName$
' Define the attributes
PPRep.visible( false )
Set objPDF = pprep.PDFFile(destPDFName$, True)
With objPDF
.SaveEntireReport = True
.SaveAllCharts = True
.AxisOnAllPAges = True
.ChartTitleOnAllPages = True
' .SetListOfLayersToSave PPRep.layers.subset(1,1)
.SaveAllCharts = True
.SetListOfRowsToSave PPRep.Rows
.IncludeLegend = True
End With
' Save the PDF
WriteLogFile("Save as PDF File: " + destPDFName$)
objPDF.Save
Set objPDF = Nothing
Set PPRep = Nothing
End sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' COMMAND SUBROTINES
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
WriteLogFile("Command Execute: " + cmdline$)
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
ret& = CloseHandle(proc.hProcess)
End Sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PROCESS FOLDER DOCUMENTS SUBROTINES
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FolderReportsSaveAsPDF(catname$, catclass$, catpassword$, databaseuser$, databasepassword$, sourcefolder$, destinationfolder$)
Dim strPFDRReportDirectory As String
Dim strPFDRReportSmallName As String
Dim strPFDRReportFileName As String
Dim strPFDRPDFDirectory As String
Dim strPFDRPDFSmallName As String
Dim strPFDRPDFFileName As String
Dim intPFDRExtensionCount as Integer
Dim strPFDRReportExtension As String
strFolder = Dir$(sourcefolder$ + "*.*")
'----Open each report file in the directory and publish as PDF
Do While StrFolder <> ""
WriteLogFile("Saving all reports in Source Folder:" + sourcefolder$ + " to PDF")
' Build Parameters required to generate a PDF from a Impromptu or Powerplay Report
' Define the Report
strPFDRReportDirectory = sourcefolder$
intPFDRExtensionCount = InStr(strFolder , ".")
strPFDRReportSmallName = Left(strFolder,intPFDRExtensionCount-1)
strPFDRReportExtension = Mid(strFolder,intPFDRExtensionCount+1, 3)
strPFDRReportFileName = strPFDRReportDirectory + strFolder
' Define the detination PDF file
strPFDRPDFDirectory = destinationfolder$
''''''strPFDRPDFSmallName = strPFDRReportSmallName + " " + ".pdf"
strPFDRPDFSmallName = strPFDRReportSmallName + ".pdf"
strPFDRPDFFileName = strPFDRPDFDirectory + strPFDRPDFSmallName
' Create and save the report as a PDF.
Select Case strPFDRReportExtension
Case "imr"
call SaveReportAsPDF( catname$, strPFDRReportFileName, catclass$, catpassword$, databaseuser$, databasepassword$, convertName(strPFDRPDFFileName))
Case "ppr"
call SavePowerPlayReportAsPDF(strPFDRReportFileName, convertName(strPFDRPDFFileName))
Case "ppx"
call SavePowerPlayReportAsPDF(strPFDRReportFileName, convertName(strPFDRPDFFileName))
Case "pyi"
' Ignore powerplay cube builds
Case Else
WriteLogFile("PDF Report not available for extension type:'" + strPFDRReportExtension + "' file:" + strFolder)
End Select
strFolder = Dir
Loop
Set PPlayRepOject = Nothing
End Sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PROCESS FOLDER DOCUMENTS SUBROTINES - Excel
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FolderReportsSaveAsExl(catname$, catclass$, catpassword$, databaseuser$, databasepassword$, sourcefolder$, destinationfolder$)
Dim strExlRReportDirectory As String
Dim strExlRReportSmallName As String
Dim strExlRReportFileName As String
Dim strExlRPDFDirectory As String
Dim strExlRPDFSmallName As String
Dim strExlRPDFFileName As String
Dim intExlRExtensionCount as Integer
Dim strExlRReportExtension As String
strFolder = Dir$(sourcefolder$ + "*.*")
'----Open each report file in the directory and publish as PDF
Do While StrFolder <> ""
WriteLogFile("Saving all reports in Source Folder:" + sourcefolder$ + " in Excel Format")
' Build Parameters required to generate a PDF from a Impromptu or Powerplay Report
' Define the Report
strExlRReportDirectory = sourcefolder$
intExlRExtensionCount = InStr(strFolder , ".")
strExlRReportSmallName = Left(strFolder,intExlRExtensionCount-1)
strExlRReportExtension = Mid(strFolder,intExlRExtensionCount+1, 3)
strExlRReportFileName = strExlRReportDirectory + strFolder
' Define the detination PDF file
strExlRPDFDirectory = destinationfolder$
strExlRPDFSmallName = strExlRReportSmallName + ".xls"
strExlRPDFFileName = strExlRPDFDirectory + strExlRPDFSmallName
' Create and save the report as a PDF.
Select Case strExlRReportExtension
Case "imr"
call SaveReportAsExl( catname$, strExlRReportFileName, catclass$, catpassword$, databaseuser$, databasepassword$, convertName(strExlRPDFFileName))
Case "ppr"
'Ignore PP reports For Excel requests
Case "ppx"
'Ignore PP reports For Excel requests
Case "pyi"
' Ignore powerplay cube builds
Case Else
WriteLogFile("Excel Report not available for extension type:'" + strExlRReportExtension + "' file:" + strFolder)
End Select
strFolder = Dir
Loop
Set PPlayRepOject = Nothing
End Sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DEPARTMENT SUBROTINES
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProcessDepartment(department$)
WriteLogFile("Start processing department: " + department$)
' Define the source folder for reports
strSourceFolder1 = GenerateDir + department$ + "\" + DayDir
' Define the destination folder for PDF
strDesinationFolder1 = SaveDir + department$ + "\"
' Create and save the report as a PDF.
call FolderReportsSaveAsPDF(strCatalogueFileName1 , strCatalogueClass1, strCataloguePassword1 , strDatabaseUser1 , strDatabasePassword1 , strSourceFolder1 , strDesinationFolder1)
' Define the folder for reports to be saved as Excel with Formats.
strSourceFolder1 = GenerateDir + department$ + "\" + DayDir + ExclDir
' Define the destination folder for Excel for Format.
strDesinationFolder1 = SaveDir + department$ + "\"
' Create and save the report as a Excel with Format.
call FolderReportsSaveAsExl(strCatalogueFileName1 , strCatalogueClass1, strCataloguePassword1 , strDatabaseUser1 , strDatabasePassword1 , strSourceFolder1 , strDesinationFolder1)
WriteLogFile("Finished processing department:" + department$)
End Sub
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' MAIN PROGRAM
' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Main()
' Build Parameters required to generate a PDF from a Impromptu Report
' Define the Catalogue
strCatalogueDirectory1 = CatalogueDir
strCatalogueSmallName1 = "IDSe42_AudiUAT.cat"
strCatalogueFileName1 = strCatalogueDirectory1 + strCatalogueSmallName1
' Define the Access to Catalogue
strCatalogueClass1 = "Admin"
strCataloguePassword1 = " "
' Define the Access to Database Server
strDatabaseUser1 = "IDSCOGNOS"
strDatabasePassword1 = "B1CUBE"
' Set todays global run date
strTodaysDate = date$
' Open log file for logging actions
OpenLogFile
'-------------------------------------------------------------------------------------
' SAVE FOLDER REPORTS AS PDF
'-------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------
' VEHICLES
call ProcessDepartment("Vehicles")
'------------------------------------------------------------------------------------------------------------
'Copy PDFs to Production
'------------------------------------------------------------------------------------------------------------
' ExecCmd "c:\winnt\robocopy \\srv-01\vol1\idse42bi\preproduction\ \\srv-01\vol1\idse42bi\production\ *.pdf /S /XO /log+:" + LogFilePath & LogFileIdentifier & Format$( Now, "yymmdd" ) & "R.LOG"
' WriteLogFile("Copy of PDF process complete. Please check todays log file for errors.")
WriteLogFile("The execution of " & MacroName & " has been finished")
' Close log file
CloseLogFile
End Sub
