Plateforme Level Extreme
Abonnement
Profil corporatif
Produits & Services
Support
Légal
English
Printing smaller
Message
De
21/12/2001 10:24:42
 
 
Information générale
Forum:
Visual FoxPro
Catégorie:
Gestionnaire de rapports & Rapports
Divers
Thread ID:
00597168
Message ID:
00597306
Vues:
38
Robin,

Since other people are also intersted and the code isn't too big, I post it here:

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)
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,
>
>I would apreciate a copy of that if I could, please send to Robin@clapworthy.freeserve.co.uk
>
>RC
>Bespoke Software Systems
Daniel
Précédent
Suivant
Répondre
Fil
Voir

Click here to load this message in the networking platform