*-- 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)Or you can call it manually:
?QuickReport(1, "c:\temp\customers.xls") && ToExcelNoShow ?QuickReport(2) && ToExcelPreview ?QuickReport(3) && ToPrinterNoShow
************************************************ 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...: o.QuickReport(1, "c:\temp\customers.xls") && ToExcelNoShow * : o.QuickReport(2) && ToExcelPreview * : o.QuickReport(3) && ToPrinterNoShow * 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! #DEFINE ccAviFile "C:\Program Files\Microsoft Visual Studio\Common\Graphics\Videos\FileMove.avi" *-- check parameters ------------------------------------------------------------------------------ IF TYPE("tnMode") "N" OR NOT BETWEEN(tnMode, 1, 3) MessageBox("QuickReport() - Parameter missing or wrong vale." + ccCrLf +; "Use one of the following:" + ccCrLf +; "1 = ToExcelNoShow" + ccCrLf +; "2 = ToExcelPreview" + ccCrLf +; "3 = ToPrinterNoShow",; MB_ICONEXCLAMATION,; icMessageBoxCaption) RETURN -1 ENDIF IF tnMode = cnToExcelNoShow *-- tcOutputFile must be passed IF TYPE("tcOutputFile") "C" OR EMPTY(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() lcDbc = DBC() IF EMPTY(lcAlias) MessageBox("QuickReport() - No table open in current work area.",; MB_ICONEXCLAMATION,; icMessageBoxCaption) RETURN -3 ENDIF DO CASE CASE tnMode = cnToExcelNoShow lcExcelFile = FORCEEXT(tcOutputFile, "XLS") lcMessageCaption = "Sending data to Excel..." *lcAviFile = "CopyToExcel.avi" CASE tnMode = cnToExcelPreview lcExcelFile = ADDBS(SYS(2023))+RIGHT(SYS(3),8)+".XLS" lcMessageCaption = "Sending data to Excel..." *lcAviFile = "CopyToExcel.avi" CASE 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 llFreeTable SET DATABASE TO (CURSORGETPROP("DATABASE")) ENDIF *-- display message IF NOT clSuppressMessages loMessage = NEWOBJECT("Animation", "Animation.prg", "",; lcMessageCaption,; icMessageBoxCaption,; ccAviFile) ENDIF lnFields = FCOUNT() DIMENSION laFields[lnFields, 1] FOR i = 1 TO lnFields lcFieldName = FIELD(i) lcFieldCaption = "" IF NOT llFreeTable *-- get field caption from DBC lcFieldCaption = DBGetProp(lcAlias+"."+lcFieldName, "Field", "Caption") ENDIF laFields[i, 1] = IIF(EMPTY(lcFieldCaption), lcFieldName, lcFieldCaption) ENDFOR &&* i = 1 TO lnFields *-- export selected fields to Excel lcSafe = SET("SAFETY") SET SAFETY OFF COPY TO (lcExcelFile) TYPE XL5 SET SAFETY &lcSafe *-------------------------------------------------------------------------------------------------- *-- 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(lcTableName) lcTableName = "Cursor - " + ALIAS() ENDIF *-- set pageSetup properties WITH oXLS.Application.ActiveSheet.PageSetup *.LeftHeader = "" .CenterHeader = 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 lnFields oXLS.Worksheets(1).Range(oXLS.Worksheets(1).Cells(1, i), oXLS.Worksheets(1).Cells(1, i)).Select oXLS.Selection.value = laFields[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 lnVfpHandle 0 SetForegroundWindow(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 lnXlsHandle 0 SetForegroundWindow(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(lcExcelFile) DELETE FILE (lcExcelFile) ENDIF ENDIF CASE 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(lcExcelFile) DELETE FILE (lcExcelFile) ENDIF ENDCASE *-- remove message IF TYPE("loMessage") = "O" AND NOT ISNULL(loMessage) RELEASE loMessage ENDIF IF NOT EMPTY(lcDbc) SET DATABASE TO (lcDbc) ELSE SET DATABASE TO ENDIF RETURN lnRetVal *-- EOF Method QuickReport ------------------------------------------------------------------------------- ************************************************ *-- Class: Animation ************************************************ * Author............: Daniel Gramunt * Created...........: 17.05.99 17:03:36 *) Description.......: Displays an animation (AVI) using the animation control that *) : ships with VFP. *) : Handy for processes for which you cannot use a thermometer. * Calling Samples...: oAnimation = NEWOBJECT("Animation", "avi.prg", "",; * : "Creating PDF file",; * : "PDF converter",; * : "FileToPdf.avi") * Parameter List....: * Major change list.: *-------------------------------------------------------------------------------------------------- DEFINE CLASS Animation AS form DataSession = 1 Height = 85 Width = 360 AutoCenter = .T. Caption = "" ControlBox = .F. Closable = .F. ClipControls = .F. Name = "frmAnimation" ADD OBJECT lblMessage AS label WITH ; WordWrap = .T., ; Caption = "Your message goes here...", ; Left = 6, ; Top = 2, ; Width = 355, ; Name = "lblMessage" PROCEDURE Load This.AddObject("oleAnimation", "oleControl", "MsComCtl2.Animation.2") WITH This.oleAnimation .Top = 28 .Left = 46 .Visible = .f. ENDWITH ENDPROC PROCEDURE Init * Parameter List....: tcMessage - Message to display. Optional. * : tcCaption - Form caption. Optional. * : If omitted, the form doesn't have a title bar * : tcAviFile - Animation file to display (default = fileCopy.avi) * Major change list.: *-------------------------------------------------------------------------------------------------- LPARAMETER tcMessage, tcCaption, tcAviFile WITH This *-- check parameters ------------------------------------------------------------------------------ IF TYPE("tcMessage") "C" OR EMPTY(tcMessage) tcMessage = "Processing. Please be patient..." ENDIF IF TYPE("tcCaption") "C" OR EMPTY(tcCaption) *-- no caption, so we remove the title bar .TitleBar = 0 ELSE .TitleBar = 1 .caption = tcCaption ENDIF IF TYPE("tcAviFile") "C" tcAviFile = "fileCopy.avi" ENDIF .lblMessage.caption = tcMessage .aviPlay(tcAviFile) .show() ENDWITH ENDPROC PROCEDURE AviPlay LPARAMETERS tcAviFile *-- make sure file exists IF FILE(tcAviFile) *-- update animation WITH ThisForm.oleAnimation .visible = .f. .stop .open(FULLPATH(tcAviFile)) .play() .Height = 60 .Width = 275 .visible = .t. ENDWITH ENDIF ENDPROC ENDDEFINE</font>Daniel,