************************************************ procedure QuickReport ************************************************ *) Description.......: Formats and sends the content of the currently selected *) : table/cursor to Excel using automation. *) : *) : The following modes are suppored: *) : *) : 1 = ToExcelNoShow *) : 2 = ToExcelPreview *) : 3 = ToPrinterNoShow (Excel file deleted) *) : *) : Returns: Numeric *) : 0 if successful *) : *) : If Error occurred: *) : -1 Parameter missing or invalid value *) : -2 Parameter missing or wrong type *) : -3 No table open in current work area *) : * Calling Samples...: QuickReport(1, "c:\temp\customers.xls") && ToExcelNoShow * : QuickReport(2) && ToExcelPreview * : QuickReport(3) && ToPrinterNoShow *If you want to launch it from a menu, you could add something like this to your startup.prg: *-- Print currently selected table to Excel *!* DEFINE BAR 3 OF DevTools PROMPT "Print Table to Excel" SKIP FOR EMPTY(ALIAS()) *!* ON SELECTION BAR 3 OF DevTools DO QuickReport(2) * Parameter List....: tnMode - See above * : tcOutputFile - Excel output file. Required for mode * Major change list.: *-------------------------------------------------------------------------------------------------- lparameters tnMode, tcOutputFile *-- possible values for #define cnToExcelNoShow 1 #define cnToExcelPreview 2 #define cnToPrinterNoShow 3 #define clSuppressMessages .f. #define ccCrLf chr(13)+chr(10) #define MB_ICONEXCLAMATION 48 && Warning message #define MB_YESNO 4 && Yes and No buttons #define MB_ICONQUESTION 32 && Warning query #define IDYES 6 && Yes button pressed #define xlLeft 1 #define xlCenter -4108 #define xlRight -4152 #define xlLandscape 2 #define xlWorkbookNormal -4143 && used by SaveAs() to save in current version #define cnInchesToPoints 72 #define cnCentimetersToPoints cnInchesToPoints / 2.54 #define icMessageBoxCaption "QuickReport - 1.02" *-- adjust the following line! * Nadya Nosonovsky 02/01/2002 11:31:31 AM - AVI should be in a path *#DEFINE ccAviFile "C:\Program Files\Microsoft Visual Studio\Common\Graphics\Videos\FileMove.avi" #define ccAviFile "Move.avi" *-- check parameters ------------------------------------------------------------------------------ if vartype(m.tnMode)<> "N" or not between(m.tnMode, 1, 3) messagebox("QuickReport() - Parameter missing or wrong value." + ccCrLf + ; "Use one of the following:" + ccCrLf + ; "1 = ToExcelNoShow" + ccCrLf + ; "2 = ToExcelPreview" + ccCrLf + ; "3 = ToPrinterNoShow", ; MB_ICONEXCLAMATION, ; icMessageBoxCaption) return -1 endif if m.tnMode = cnToExcelNoShow *-- tcOutputFile must be passed if vartype(m.tcOutputFile)<>"C" or empty(m.tcOutputFile) messagebox("QuickReport() - Parameter missing or wrong type.", ; MB_ICONEXCLAMATION, ; icMessageBoxCaption) return -2 endif endif local lcExcelFile, lcMessageCaption, lcAviFile, lcAlias, lcDbc local llFreeTable, loMessage, lnFields, i, lcFieldName, lcFieldCaption local lcSafe, oXLS, lcTableName, lnRetVal, lnVfpHandle lcAlias = alias() lcTableName = lower(juststem(dbf(m.lcAlias))) lcDbc = dbc() if empty(m.lcAlias) messagebox("QuickReport() - No table open in current work area.",; MB_ICONEXCLAMATION,; icMessageBoxCaption) return -3 endif do case case m.tnMode = cnToExcelNoShow lcExcelFile = forceext(m.tcOutputFile, "XLS") lcMessageCaption = "Sending data to Excel..." *lcAviFile = "CopyToExcel.avi" case m.tnMode = cnToExcelPreview lcExcelFile = addbs(sys(2023))+right(sys(3),8)+".XLS" lcMessageCaption = "Sending data to Excel..." *lcAviFile = "CopyToExcel.avi" case m.tnMode = cnToPrinterNoShow lcExcelFile = addbs(sys(2023))+right(sys(3),8)+".XLS" lcMessageCaption = "Sending data to printer..." *lcAviFile = "CopyToPrinter.avi" endcase llFreeTable = empty(cursorgetprop("DATABASE")) if not m.llFreeTable set database to (cursorgetprop("DATABASE")) endif *-- display message if not clSuppressMessages loMessage = newobject("Animation", "Animation.vcx", "", ; && Now use Daniel's vcx class instead lcMessageCaption,; icMessageBoxCaption,; ccAviFile) endif lnFields = fcount() dimension laFields[m.lnFields, 1] for i = 1 to m.lnFields lcFieldName = lower(field(m.i)) lcFieldCaption = "" if not m.llFreeTable *-- get field caption from DBC * Nadya Nosonovsky 02/01/2002 12:42:42 PM made a small fix to use tablename insted of alias lcFieldCaption = dbgetprop(m.lcTableName+"."+m.lcFieldName, "Field", "Caption") endif laFields[m.i, 1] = iif(empty(m.lcFieldCaption), proper(m.lcFieldName), m.lcFieldCaption) endfor &&* i = 1 TO lnFields *-- export selected fields to Excel lcSafe = set("SAFETY") set safety off copy to (m.lcExcelFile) type xl5 if m.lcSafe='ON' set safety on endif *-------------------------------------------------------------------------------------------------- *-- open Excel file and format worksheet *-------------------------------------------------------------------------------------------------- oXLS = createobject("Excel.Application") oXLS.application.Workbooks.open(lcExcelFile) oXLS.application.DisplayAlerts = .f. *-- get tablename lcTableName = dbf() *-- use name of alias if we're dealing with a cursor if ".TMP" $ upper(m.lcTableName) lcTableName = "Cursor - " + alias() endif *-- set pageSetup properties with oXLS.application.ActiveSheet.PageSetup *.LeftHeader = "" .CenterHeader = m.lcTableName *.RightHeader = "" .LeftFooter = icMessageBoxCaption .CenterFooter = "&P of &N" .RightFooter = "&D - &T" .LeftMargin = cnCentimetersToPoints * 1.9 .RightMargin = cnInchesToPoints * 0.27244094488189 .TopMargin = cnInchesToPoints * 0.47244094488189 .BottomMargin = cnInchesToPoints * 0.47244094488189 .HeaderMargin = cnInchesToPoints * 0.236220472440945 .FooterMargin = cnInchesToPoints * 0.236220472440945 *.PrintHeadings = .f. *.PrintGridlines = .f. *.PrintComments = xlPrintNoComments *.PrintQuality = 600 *.CenterHorizontally = .t. *.CenterVertically = .t. .orientation = xlLandscape *.Draft = .f. *.PaperSize = xlPaperA4 *.FirstPageNumber = xlAutomatic *.Order = xlDownThenOver *.BlackAndWhite = .f. .zoom = .f. .FitToPagesWide = 1 .FitToPagesTall = .f. .PrintTitleRows = "$1:$1" && repeats header on each page endwith *-- format column headings *-- change column captions for i = 1 to m.lnFields oXLS.Worksheets(1).range(oXLS.Worksheets(1).Cells(1, i), oXLS.Worksheets(1).Cells(1, i)).select oXLS.selection.value = laFields[m.i, 1] endfor *-- select first row oXLS.Worksheets(1).range(oXLS.Worksheets(1).Cells(1, 1), oXLS.Worksheets(1).Cells(1, lnFields)).select oXLS.selection.AutoFormat(1) *-- format header row with oXLS.selection.font *.Name = "Arial" *.Size = 12 .Bold = .t. .Italic = .f. .shadow = .f. endwith with oXLS *-- set width of each column to fit content .columns().EntireColumn.AutoFit .selection.Interior.ColorIndex = 15 && grey background .selection.HorizontalAlignment = xlLeft endwith lnRetVal = 0 declare Sleep in WIN32API integer nMillisecs *-- perform output/save actions based on do case case tnMode = cnToExcelNoShow *-- save formatted Excel file oXLS.ActiveSheet.saveas(lcExcelFile, xlWorkbookNormal) oXLS.application.quit lnRetVal = iif(file(lcExcelFile), 0, -35) case tnMode = cnToExcelPreview *-- preview oXLS.visible=.t. oXLS.application.DisplayAlerts = .t. oXLS.ActiveWindow.SelectedSheets.PrintPreview *-- we don't close Excel after the user closes the *-- preview window. Note that we haven't yet saved the *-- Excel file. This allows the user to either discard *-- the file or save it manually. declare integer FindWindow in Win32api string, string declare SetForegroundWindow in Win32api integer lnVfpHandle = FindWindow(.null., _screen.caption) *-- bring VFP to the foreground before displaying the messagebox if m.lnVfpHandle <> 0 SetForegroundWindow(m.lnVfpHandle) endif if messagebox("Do you want to save the Excel file?", MB_YESNO+MB_ICONQUESTION, icMessageBoxCaption) = IDYES *-- nothing to do, keep Excel open and bring Excel to the foreground lnXlsHandle = FindWindow(.null., oXLS.caption) if m.lnXlsHandle <> 0 SetForegroundWindow(m.lnXlsHandle) endif else *-- user doesn't want to save the Excel file, *-- so we quit Excel without saving and delete the file oXLS.DisplayAlerts = .f. oXLS.application.quit release oXLS Sleep(500) if file(m.lcExcelFile) delete file (m.lcExcelFile) endif endif case m.tnMode = cnToPrinterNoShow oXLS.ActiveWindow.SelectedSheets.PrintOut() *-- quit Excel without saving and delete the file oXLS.DisplayAlerts = .f. oXLS.application.quit release oXLS Sleep(500) if file(m.lcExcelFile) delete file (m.lcExcelFile) endif endcase *-- remove message if vartype(m.loMessage) = "O" and not isnull(loMessage) release loMessage endif if not empty(m.lcDbc) set database to (m.lcDbc) else set database to endif return m.lnRetVal *-- EOF Method QuickReport -------------------------------------------------------------------------------