/* Name : Viper.p Purpose: Progress wrapper for viper.dll (*persistent*) Copyright: IAP GmbH 1997 - 2002 Author: Klaus Erichsen, Jirko Cassuben, Bernd Hellmann ... Version: 970728 ... jc, 04.10.01: SetDocTitle bh, 01.03.02: New API for Viper3.0 changed cfg viper.i included Last change: bh 03.02.03 16:33:17 */ /** define OPTIONS/SWITCHES */ /* * Configuration file included by viper.p. * Allows user to configure certain aspects of * viper */ /** Application directory DIR */ /** relative Viper subdir DIR */ /** Basic Viper Function API [*yes|no] */ /** Frame Designer API [*yes|no] */ /** vfl/vfr IO [*yes|no] */ /** xml IO [yes|*no] */ /** db IO [yes|*no] */ /** Basic Viper API [*yes|no] */ /** Should Viper.p run in "empty" mode? This is used for speed tests. If Empty is set to on, every procedure call is immediately ended. [*off|on] */ /** Delimiter possible for use in Progress programs. STRING */ /** use persitence ? */ /** improve Viper-speed but slow down Progress (0 or HIGH values guarantee increased Progress-speed) INT [0 - 9999] */ /** Path of viper32.dll */ /** SHOULD PDFPRINTING BE ACTIVATED? [*on|off] */ /** SHOULD WEBPRINTING BE ACTIVATED? ONLY DO THIS, WHEN YOU ARE USING WEBSPEED!!!! [on|*off] */ /** Select the printername used for webprinting This has to be a postscript printerdriver!!! You do not really need to have a postscript printer to use this, it is enough to have the driver installed. */ /** the ghostscript installation directory */ /** the ghostscript exe file */ /** the ghostscript lib-dir (for people using a stock gs 6.01: add "\lib") */ /** font path providing fonts to gs seperate directories by ; */ /** temporary directory used for web printing. THIS IS THE PATH FOR WEBSPEED */ /** temporary directory used for web printing. THIS IS THE PATH FOR THE WEBSERVER */ /** Basic Viper Function API */ /* Name : Vpf.i Purpose: Function interface Copyright: Author: Version: 25/02/03 added vpr_toRTF Last change: IAP 17 Mar 2003 2:59 am * 17.03.2003 jc vpr_GetPreviewStatus * 04.05.2005 jc vpr_GetCellTextHeight * 03.08.2006 jc vpr_GetGroupHPos, vpr_GetGroupWidth */ /** GetCellWidth - retrieve the width of a cell **/ FUNCTION vpr_GetCellWidth RETURNS INT ( INPUT p-cell AS CHAR, INPUT p-group AS CHAR) : DEF VAR p-width AS INT NO-UNDO. RUN VpGetCellWidth(CAPS(p-cell), CAPS(p-group), OUTPUT p-width). RETURN (p-width). END. /** gives height of cell **/ FUNCTION vpr_GetCellHeight RETURNS INT ( INPUT p-cell AS CHAR, INPUT p-group AS CHAR): DEF VAR p-height AS INT NO-UNDO. RUN VpCellHeight(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). RETURN (p-height). END. /** Returns height of group. The height of the group is the height of the heighest cell. */ FUNCTION vpr_GetGroupHeight RETURNS INT ( INPUT p-group AS CHAR): DEF VAR p-height AS INT NO-UNDO. RUN VpGroupHeight(CAPS(p-group), OUTPUT p-height). RETURN(p-height). END. /** Returns free vertical space on page (with flushed cells) */ FUNCTION vpr_GetPageVSpace RETURNS INT (): DEF VAR p-space AS INT NO-UNDO. RUN VpGetFree(OUTPUT p-space). RETURN (p-space). END. /** Returns vertical position of cursor */ FUNCTION vpr_GetPageVPos RETURNS INT () : DEF VAR p-pos AS INT NO-UNDO. RUN VpGetPos(OUTPUT p-pos). RETURN(p-pos). END. /** Returns number of pages (=actual page) */ FUNCTION vpr_GetPageNo RETURNS INT (): DEF VAR p-page AS INT NO-UNDO. RUN VpGetPages(OUTPUT p-page). RETURN(p-page). END. /** GetCellVPos - get the vertical position of a cell */ FUNCTION vpr_GetCellVPos RETURNS INT ( INPUT p-group AS CHAR, INPUT p-cells AS CHAR) : DEF VAR p-VPos AS INT NO-UNDO. RUN VpGetCellVPos(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-VPos). RETURN(p-vpos). END. /** GetCellHPos - get the horizontal position of a cell*/ FUNCTION vpr_GetCellHPos RETURNS INT ( INPUT p-group AS CHAR, INPUT p-cells AS CHAR): DEF VAR p-HPos AS INT NO-UNDO. RUN VpGetCellHPos(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-HPos). RETURN(p-hpos) . END. /** GetGroupVPos - get the vertical position of a group */ FUNCTION vpr_GetGroupVPos RETURNS INT ( INPUT p-group AS CHAR): DEF VAR p-VPos AS INT NO-UNDO. RUN VpGetGroupVPos(INPUT CAPS(p-group), OUTPUT p-VPos). RETURN (p-vpos). END. /** GetCellLineCount - return the number of lines in a cell*/ FUNCTION vpr_GetCellLineCount RETURNS INT ( INPUT p-group AS CHAR, INPUT p-cells AS CHAR): DEF VAR p-LineCount AS INT NO-UNDO. RUN VpGetCellLineCount(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-LineCount). RETURN (p-LineCount). END. FUNCTION vpr_GetPrinterAttrib RETURNS CHAR ( INPUT p_attrib AS CHAR) : DEF VAR p_value AS INT NO-UNDO. RUN VpGetPrinterAttrib(CAPS(p_attrib), OUTPUT p_value). RETURN(TRIM(STRING(p_value))). END. /* takes string + attributes and returns rtf-formatted string */ FUNCTION vpr_toRTF RETURNS CHAR( INPUT p-InString AS CHAR, INPUT p-Attribs AS CHAR): DEF VAR p-OutString AS CHAR NO-UNDO. RUN vpr_Asc2RTF (p-InString, p-Attribs, OUTPUT p-OutString). RETURN (p-OutString). END FUNCTION. /* * Get the current preview state (hidden/visible) * * 17.03.03 jc */ FUNCTION vpr_GetPreviewStatus RETURNS CHAR ( INPUT p-wait AS INT) : DEF VAR p-status AS INT NO-UNDO. RUN VpGetPreviewStatus(INPUT p-wait, OUTPUT p-status). RETURN IF p-status=1 THEN "visible" ELSE "hidden". END. /** return height the cell would need to display the whole text * 04.05.05 jc **/ FUNCTION vpr_GetCellTextHeight RETURNS INT ( INPUT p-cell AS CHAR, INPUT p-group AS CHAR): DEF VAR p-height AS INT NO-UNDO. RUN VpGetCellTextHeight(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). RETURN (p-height). END. /** return width the cell would needs to display the text without additional * linebreaking * 04.05.05 jc **/ FUNCTION vpr_GetCellTextWidth RETURNS INT ( INPUT p-cell AS CHAR, INPUT p-group AS CHAR): DEF VAR p-height AS INT NO-UNDO. RUN VpGetCellTextWidth(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). RETURN (p-height). END. /** return width the cell would needs to display the text without additional * linebreaking * 04.05.05 jc **/ FUNCTION vpr_GetGroupHPos RETURNS INT ( INPUT p-group AS CHAR): DEF VAR p-hpos AS INT NO-UNDO. RUN VpGetGroupHPos(CAPS(p-group), OUTPUT p-hpos). RETURN (p-hpos). END. /** return width the cell would needs to display the text without additional * linebreaking * 04.05.05 jc **/ FUNCTION vpr_GetGroupWidth RETURNS INT ( INPUT p-group AS CHAR): DEF VAR p-width AS INT NO-UNDO. RUN VpGetGroupWidth(CAPS(p-group), OUTPUT p-width). RETURN (p-width). END. FUNCTION vpr_GetGroupObjects RETURNS CHARACTER (INPUT p-group AS CHARACTER, INPUT p-type AS CHARACTER): DEFINE VARIABLE lp-list AS MEMPTR NO-UNDO. DEFINE VARIABLE lp-ret AS CHARACTER NO-UNDO. SET-SIZE(lp-list) = 32000. RUN VpGetGroupObjects(CAPS(p-group), CAPS(p-type), OUTPUT lp-list). lp-ret = STRING(lp-list). /*SET-SIZE(lp-list) = 0.*/ RETURN lp-ret. END FUNCTION. /** Frame Designer API */ /* File: wt.i Author: Klaus Erichsen Purpose: Worktable-include for main frame ke, 981121; Added images ke, 990426; Tested: Work-Tables are much faster then Temp-Tables ke, 000819; Added remarks to the objects ke, 000819; Default values are no longer stored in the vfl. WARNING: NEVER CHANGE A DEFAULT VALUE IN THE FUTURE!!! bh, 041116; WORK -> TEMP-TABLE bh, 041116; order and private-data Last change: BH 18 Apr 2002 2:14 pm */ /* use WORK or TEMP tables */ /* The secret factor to calculate from pixel to 1/10 mm It is 1/72 inch, I think. */ /* First/last font number for cells. */ DEF VAR l-FirstCellFont AS INT NO-UNDO INIT 12. DEF VAR l-LastCellFont AS INT NO-UNDO INIT 27. /* Color used for choose from color-wheel. */ DEF VAR s-RecColor AS INT INIT 16 NO-UNDO. /* Decides whether we are in debug mode or not. */ DEF VAR g-Debug AS LOG NO-UNDO. /* Hold the setup information of the active vfl file. */ DEF TEMP-TABLE VflSetupDef NO-UNDO FIELD Version AS CHAR. DEF BUFFER VflSetup FOR TEMP-TABLE VflSetupDef. CREATE VflSetup. /* Worktable to hold Viper Reports. */ DEF TEMP-TABLE VRepDef NO-UNDO FIELD Num AS INT INIT 0 /* unique number */ FIELD WorkCopy AS LOG INIT FALSE /* Is this one a working copy? */ FIELD Name AS CHAR INIT "" FORMAT "X(32)" /* unique name */ FIELD ActNum AS INT /* unique number for all objects in report */ FIELD FontNam AS CHAR EXTENT 16 INIT "Times New Roman, size=12" FIELD GridWidth AS INT INIT 8 /* 2 mm */ FIELD GridHeight AS INT INIT 8 FIELD GridVertical AS INT INIT 3 FIELD GridHorizontal AS INT INIT 3 /* Paper size (not in use) */ FIELD Width-mm AS INT INIT 0 FIELD Height-mm AS INT INIT 0 /* Paper orientation, default is Portrait. */ FIELD Portrait AS LOG INIT TRUE /* PaperType (A4, etc) */ FIELD PaperType AS CHAR INIT "" /* */ FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0. DEF BUFFER VReport FOR TEMP-TABLE VRepDef. /* Worktable for groups. */ DEF TEMP-TABLE VGroup NO-UNDO FIELD Num AS INT FIELD ReportNum AS INT FIELD Name AS CHAR /* Skip before and after an group. */ FIELD PreSkip AS INT FIELD PostSkip AS INT FIELD Unit AS CHAR INIT "mm" FIELD RelPos AS LOG /* Should relative cell positioning be keeped? */ FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0 . /* Worktable to hold Viper objects. */ DEF TEMP-TABLE VObj NO-UNDO /* Name of report and the unique number of object. */ FIELD Num AS INT FIELD ReportNum AS INT FIELD GroupNum AS INT FIELD Name AS CHAR /* Objects are only: cell, text */ FIELD Type AS CHAR /* Is this field new created via dialog? */ FIELD Newbie AS LOG INIT FALSE /* Value of cell, used for type text. */ FIELD TextValue AS CHAR /* X,Y,width,height */ FIELD X AS INT FIELD Y AS INT FIELD Width AS INT FIELD Height AS INT /* X,Y,width,height in 1/10 mm. This is screen-independent. */ FIELD X-mm AS INT FIELD Y-mm AS INT FIELD Width-mm AS INT FIELD Height-mm AS INT /* Orientation (caution: is int in viper api) */ FIELD Align AS CHAR INIT "Left" /* Foregroundcolor/Backgroundcolor. */ FIELD FgColour AS CHAR FIELD BgColour AS CHAR /* Font number. This is the Viper font number. */ FIELD FontNo AS INT INIT 1 /* Word Wrap (caution: is log in viper api) */ FIELD AutoWrap AS CHAR INIT "Off" /* RTF allowed */ FIELD RTFAllow AS LOG /* Should the cell automatically resize in vertical direction? */ FIELD AutoResize AS LOG INIT TRUE FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0 /* zOrder of the cell. - currently unused */ FIELD zOrder AS INTEGER INIT ? /* should the cell keep it text value after a flush group? useful for labels */ FIELD KeepText AS LOG INIT FALSE /* default to NO */ . /* Worktable for Rectangles. */ DEF TEMP-TABLE VRec NO-UNDO FIELD Num AS INT FIELD ReportNum AS INT FIELD GroupNum AS INT FIELD Name AS CHAR FIELD Rounded AS LOG /* make the rectangle rounded? */ FIELD Filled AS LOG FIELD EdgePix AS INT INIT 1 /* This is no true attribute of viper. */ /* Color is defined as bgcolor according to Progress. */ FIELD BgColour AS CHAR FIELD Newbie AS LOG /* X,Y,width,height */ FIELD X AS INT FIELD Y AS INT FIELD Width AS INT FIELD Height AS INT /* X,Y,width,height in 1/10 mm. This is screen-independent. */ FIELD X-mm AS INT FIELD Y-mm AS INT FIELD Width-mm AS INT FIELD Height-mm AS INT FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0 /* zOrder */ FIELD zOrder AS INTEGER INIT ? . /* Worktable for Lines. */ DEF TEMP-TABLE VLin NO-UNDO FIELD Num AS INT FIELD ReportNum AS INT FIELD GroupNum AS INT FIELD Name AS CHAR FIELD Type AS CHAR INIT "H" /* h: horizontal v: vertical */ FIELD X AS INT /* Starting point */ FIELD Y AS INT FIELD Len AS INT /* Length of an horizontal/vertical line */ FIELD Height AS INT /* Height of an horizontal line */ /* Look alike. The 0 value is a solid line. */ FIELD Style AS INT INIT 0 /* X,Y,width,height in 1/10 mm. This is screen-independent. */ FIELD X-mm AS INT FIELD Y-mm AS INT FIELD Len-mm AS INT FIELD Height-mm AS INT /* Color is defined as bgcolor according to Progress. */ FIELD BgColour AS CHAR FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0 /* zOrder */ FIELD zOrder AS INTEGER INIT ? . /* Worktable for images. */ DEF TEMP-TABLE VImg NO-UNDO FIELD Num AS INT FIELD ReportNum AS INT FIELD GroupNum AS INT FIELD Name AS CHAR /* The handle to get the object in the frame. */ FIELD Newbie AS LOG /* Adjust image to fit into defined space? */ FIELD Adjust AS LOG INIT TRUE /* Should the adjustment remember the original x/y ration? */ FIELD Ratio AS LOG INIT TRUE /* The image itself. */ FIELD ImgFile AS CHAR /* Image type. Known types are: bmp: windows bitmap */ FIELD ImgType AS CHAR INIT "Bmp" /* X,Y,width,height */ FIELD X AS INT FIELD Y AS INT FIELD Width AS INT FIELD Height AS INT /* X,Y,width,height in 1/10 mm. This is screen-independent. */ FIELD X-mm AS INT FIELD Y-mm AS INT FIELD Width-mm AS INT FIELD Height-mm AS INT FIELD Rem AS CHAR INIT "" /* remarks */ FIELD Private-Data AS CHAR INIT "" /* additional information not used in vfd*/ FIELD Order AS INT INIT 0 /* zOrder */ FIELD zOrder AS INTEGER INIT ? . /* File: vfd.i (taken from VReport.p) Author: Klaus Erichsen Purpose: Viper Frame Designer - realize reports 20.11.97, ke; changed program to persistent start 11.04.00, ke; fixed bug with fonts with numbers greater 8 bh, 041116; order and private-data Last change: bh 31.01.03 16:37:30 */ /* Name of Report from Library. */ DEF VAR l-RepName AS CHAR NO-UNDO. /* Should this program run in testmode? The testmode is used from the Viper Frame Designer. For normal use set it to false. */ DEF VAR l-TestMode AS LOG NO-UNDO. /* Information about the fonts. */ DEF VAR l-Format AS CHAR EXTENT 16 NO-UNDO. DEF VAR l-Size AS DEC EXTENT 16 NO-UNDO. DEF VAR l-Font AS CHAR EXTENT 16 NO-UNDO. PROCEDURE vpr_ActivateReport: DEF INPUT PARAM p-RepName AS CHAR NO-UNDO. FIND FIRST VReport WHERE VReport.Name = p-RepName NO-LOCK NO-ERROR. RUN vpr_ActivateReportNum (VReport.Num). RETURN. END PROCEDURE. PROCEDURE vpr_ActivateReportNum: DEF INPUT PARAM p-RepNum AS INT NO-UNDO. /* String for font analysis. */ DEF VAR fstr AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. /* Now put the wished report into scope. */ FIND FIRST VReport WHERE VReport.Num = p-RepNum NO-LOCK NO-ERROR. /* Store report name for later use. */ l-RepName = VReport.Name. /* Now get the font information from the report. */ DO ii = 1 TO 16: fstr = VReport.FontNam[ii] + " ". /* The fontname is the first entry and limited with an comma, e.g. Font2=Arial, size=14 italic bold Font3=Times New Roman, size=16 */ l-Font[ii] = TRIM(ENTRY(1, fstr)). l-Format[ii] = (IF INDEX (fstr, "bold") > 0 THEN ",bold" ELSE "") + (IF INDEX (fstr, "italic") > 0 THEN ",italic" ELSE "") + (IF INDEX (fstr, "underline") > 0 THEN ",underline" ELSE "") + (IF INDEX (fstr, "strikeout") > 0 THEN ",strikeout" ELSE ""). /* Get the size . Some fonts have no size entry. */ IF INDEX( fstr, "size" ) > 0 THEN ASSIGN /* get partial string behind size value. */ fstr = SUBSTR(fstr, INDEX( fstr, "size" ) + 5) /* get numeric string (which ends with an " ". */ fstr = SUBSTR(fstr, 1, INDEX( fstr, " " ) - 1) fstr = REPLACE(fstr,".",SESSION:NUMERIC-DECIMAL-POINT). l-size[ii] = DECIMAL(fstr). END. /* of do ii */ RUN vpr_InitDoc. END PROCEDURE. /* activatereport */ /* * set some document/report properties * 25.08.05 jc */ PROCEDURE vpr_InitDoc: RUN vpr_setDocAttrib("PAPERSIZE=" + VReport.PaperType). /* Set orientation. */ IF NOT VReport.Portrait THEN RUN vpr_SetPageOrientation IN THIS-PROCEDURE ("Landscape"). END PROCEDURE. /*- Initializes one, some or all groups. */ PROCEDURE vpr_InitGroups: /* Separeted list of groups. If empty then realize all groups. */ DEF INPUT PARAM p-Groups AS CHAR NO-UNDO. DEF VAR lp-ActGrp AS CHAR NO-UNDO. /* Working vars */ DEF VAR l-Line AS CHAR NO-UNDO. DEF VAR l-Key AS CHAR NO-UNDO. DEF VAR l-Val AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. /* If Empty then fill with all groups. */ IF p-Groups = "" THEN DO: FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: p-Groups = p-Groups + "," + VGroup.Name. END. p-Groups = SUBSTRING(p-Groups, 2). END. /** Go through the groups. */ DO ii = 1 TO NUM-ENTRIES(p-Groups): FIND FIRST VGroup WHERE VGroup.ReportNum = VReport.Num AND VGroup.Name = ENTRY(ii, p-Groups) NO-ERROR. IF NOT AVAILABLE VGroup THEN DO: MESSAGE 'Gruppe ' ENTRY(ii, p-Groups) ' nicht vorhanden ' VIEW-AS ALERT-BOX. NEXT. END. /* Set the Skip area around the group. */ IF VGroup.PreSkip > 0 OR VGroup.PostSkip > 0 THEN RUN vpr_SetGroupSkip IN THIS-PROCEDURE (VGroup.Name, VGroup.Unit, VGroup.PreSkip, VGroup.PostSkip). /* Set the cell pos mode if mode is rel position (0 is default). */ IF VGroup.RelPos THEN RUN vpr_SetGroupCellPositioning IN THIS-PROCEDURE (VGroup.Name, 1). FOR EACH VObj WHERE VObj.ReportNum = VReport.Num AND VObj.GroupNum = VGroup.Num: /* Define the cell. That's not needed. Cell is defined automatically. RUN DefCell IN THIS-PROCEDURE (VObj.Name, VGroup.Name). */ /*- Set the Position. */ RUN vpr_SetCellPos IN THIS-PROCEDURE ( VObj.Name, VGroup.Name /* identification */ ,VObj.x-mm, VObj.y-mm /* position */ ,VObj.Width-mm, VObj.Height-mm). /* Size */ /* Set the Alignment if not the default left alignment. */ IF NOT CAN-DO(",Left", VObj.Align) THEN RUN vpr_SetCellAlign IN THIS-PROCEDURE ( VObj.Name, VGroup.Name ,LOOKUP(VObj.Align, "Right,Centered,Justify") + 1). /* Set the color if defined. */ IF VObj.FgColour <> "" OR VObj.BgColour <> "" THEN RUN vpr_SetCellColor IN THIS-PROCEDURE ( VObj.Name, VGroup.Name, VObj.FgColour, VObj.BgColour). /* Set the font if defined (which should be normal). */ IF VObj.FontNo >= 1 AND VObj.FontNo <= 16 THEN RUN vpr_SetCellFont IN THIS-PROCEDURE ( VObj.Name, VGroup.Name, l-Size[VObj.FontNo], 0, l-Format[VObj.FontNo], l-Font[VObj.FontNo]). /* Set the Autowrap feature. */ IF VObj.Autowrap = "On" OR VObj.Autowrap = "TRUE" THEN RUN vpr_SetCellWrap IN THIS-PROCEDURE ( VObj.Name, VGroup.Name, "ON"). /* Set the RTF feature. Now use new syntax. */ IF VObj.RTFAllow THEN RUN vpr_SetCellRTF IN THIS-PROCEDURE (VObj.Name, VGroup.Name, "ON"). /* Set the Auto-Resize feature. Autoresize is on as default. */ IF NOT VObj.AutoResize THEN RUN vpr_SetCellAutoResize IN THIS-PROCEDURE (VObj.Name, VGroup.Name, "ON"). /* Set the KeepText (cellsplit=keeptext) feature. by default it is of. * this is useful for repeated (line?)-labels. */ IF VObj.KeepText THEN RUN vpr_SetCellSplit IN THIS-PROCEDURE (VObj.Name, VGroup.Name, "Copy"). /* Set the Value for test-mode or text-cell. */ IF l-TestMode OR VObj.TYPE = "Text" THEN RUN vpr_SetCellText IN THIS-PROCEDURE ( VObj.Name, VGroup.Name , IF VObj.Type = "Text" THEN VObj.TextValue ELSE VObj.NAME ). END. /* of for each vobj. */ /* * handle the grouped graphical object * (GraphObj) */ DEFINE VARIABLE lp-attribs AS CHARACTER NO-UNDO. /* we start with the lines */ FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND VLin.GroupNum = VGroup.Num: /* * build the attribute string. parts of this differ for each object * type, because the objects can have different attributes */ RUN ip_stylenumber2string(VLin.Style, OUTPUT l-val). lp-attribs = "Style=" + l-val + ",Color=" + REPLACE(VLin.BgColour, ",", ":") + (IF VLin.zOrder <> ? THEN ",zOrder=" + STRING(VLin.zOrder) ELSE "") . IF VLin.Type = "H" THEN RUN vpr_SetGraphObj(VLin.name, VGroup.Name, "LINE", VLin.x-mm, VLin.y-mm, VLin.x-mm + VLin.Len-mm, VLin.y-mm, lp-attribs). IF VLin.type = "V" THEN RUN vpr_SetGraphObj(VLin.name, VGroup.Name, "LINE", VLin.x-mm, VLin.y-mm, VLin.x-mm, VLin.y-mm + VLin.Len-mm, lp-attribs). END. /* of for each Vlin */ /* Bring the rectangles in view. */ FOR EACH VRec WHERE VRec.ReportNum = VReport.Num AND VRec.GroupNum = VGroup.Num: /* Calc pixel size for rectangle check. */ /* calc.i Make some calculations */ /* of Pixel to mm */ VRec.Width = VRec.Width-mm / 2.54. /* of Pixel to mm */ /* calc.i Make some calculations */ /* of Pixel to mm */ VRec.Height = VRec.Height-mm / 2.54. /* of Pixel to mm */ lp-attribs = "Color=" + REPLACE(VRec.BgColour, ",", ":") + (IF VRec.Filled THEN ",Fill=TRUE" ELSE "") + (IF VRec.zOrder <> ? THEN ",zOrder=" + STRING(VRec.zOrder) ELSE "") + (IF VRec.EdgePix <> ? THEN ",LineWidth=" + STRING(VRec.EdgePix) ELSE "") . RUN vpr_SetGraphObj(VRec.Name, VGroup.Name, (IF NOT VRec.Rounded THEN "RECT" ELSE "RNDRECT"), VRec.x-mm, VRec.y-mm, VRec.Width-mm, VRec.Height-mm, lp-attribs). END. /* for each VRec */ /* And now add the images. */ FOR EACH VImg WHERE VImg.ReportNum = VReport.Num AND VImg.GroupNum = VGroup.Num: FILE-INFO :FILE-NAME = VImg.ImgFile. lp-attribs = "Resize=" + STRING(VImg.Adjust) + ",KeepRatio=" + STRING(VImg.Ratio) + (IF FILE-INFO:FULL-PATHNAME <> ? THEN ",InitFile=" + FILE-INFO:FULL-PATHNAME ELSE "") + (IF VImg.zOrder <> ? THEN ",zOrder=" + STRING(VImg.zOrder) ELSE "") . RUN vpr_SetGraphObj(VImg.Name, VGroup.Name, "IMAGE", VImg.x-mm, VImg.y-mm, VImg.Width-mm, VImg.Height-mm, lp-attribs). /* RUN vpr_DefBMP IN THIS-PROCEDURE ( FILE-INFO :FULL-PATHNAME , VImg.x-mm , VImg.y-mm , VImg.Width-mm , VImg.Height-mm , (IF VImg.Adjust THEN "Resize" ELSE "NoResize") + "," + (IF VImg.Ratio THEN "KeepRatio" ELSE "NoKeepRatio") ). */ END. /* of for each VImg */ /* Show something in test-mode. */ IF l-testmode THEN RUN vpr_FlushGroup IN THIS-PROCEDURE (VGroup.Name). /* Bring the grouprelated Lines in view. --- completely deprecated */ /* FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND VLin.GroupNum = VGroup.Num: IF VLin.Type = "H" THEN RUN vpr_DefHLine IN THIS-PROCEDURE ( VLin.x-mm , VLin.y-mm , VLin.Len-mm , STRING(VLin.Style) , VLin.Height-mm , VLin.BgColour ). IF VLin.type = "V" THEN RUN vpr_DefVLine IN THIS-PROCEDURE ( VLin.x-mm , VLin.y-mm , VLin.Len-mm , STRING(VLin.Style) , VLin.Height-mm , VLin.BgColour ). END. */ /* of for each Vlin */ END. /* of for each num-entries */ END PROCEDURE. /* initgroups */ /* Eingebaut fur Schmidt von Thyssen. */ PROCEDURE vpr_ReInitTextCells: /* Separeted list of groups. If empty then realize all groups. */ DEF INPUT PARAM p-Groups AS CHAR NO-UNDO. DEF VAR lp-ActGrp AS CHAR NO-UNDO. /* Working vars */ DEF VAR l-Line AS CHAR NO-UNDO. DEF VAR l-Key AS CHAR NO-UNDO. DEF VAR l-Val AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. /* If Empty then fill with all groups. */ IF p-Groups = "" THEN DO: FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: p-Groups = p-Groups + "," + VGroup.Name. END. p-Groups = SUBSTRING(p-Groups, 2). END. /** Go through the groups. */ DO ii = 1 TO NUM-ENTRIES(p-Groups): FIND FIRST VGroup WHERE VGroup.ReportNum = VReport.Num AND VGroup.Name = ENTRY(ii, p-Groups). FOR EACH VObj WHERE VObj.ReportNum = VReport.Num AND VObj.GroupNum = VGroup.Num AND VObj.Type = "Text": /* Set the Value for text-cell. */ RUN vpr_SetCellText IN THIS-PROCEDURE ( VObj.Name , VGroup.Name , VObj.TextValue ). END. /* of for each vobj. */ END. /* of for each num-entries */ END PROCEDURE. /* reinittextcells */ /* Deletes one, some or all groups. It is useful, if you printing more as one Report in one Document */ PROCEDURE vpr_DelGroups: /* Separeted list of groups. If empty then delete all groups. */ DEF INPUT PARAM p-Groups AS CHAR NO-UNDO. /* Working vars */ DEF VAR l-Line AS CHAR NO-UNDO. DEF VAR l-Key AS CHAR NO-UNDO. DEF VAR l-Val AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. DEF VAR l-text AS LOG NO-UNDO. /* If Empty then fill with all groups. */ IF p-Groups = "" THEN DO: FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: p-Groups = p-Groups + "," + VGroup.Name. END. p-Groups = SUBSTRING(p-Groups, 2). END. /* Find the group and delete all cells in this Group */ DO ii = 1 TO NUM-ENTRIES(p-Groups): FIND FIRST VGroup WHERE VGroup.ReportNum = VReport.Num AND VGroup.Name = ENTRY(ii, p-Groups). RUN vpr_DelCell IN THIS-PROCEDURE ("*", VGroup.Name). END. /* of for each num-entries */ END PROCEDURE. /* Delgroups */ PROCEDURE vpr_InitRect: /* Bring the rectangles in view. */ FOR EACH VRec WHERE VRec.ReportNum = VReport.Num AND (VRec.GroupNum = 0 OR VRec.GroupNum = ?): /* Calc pixel size for rectangle check. */ /* calc.i Make some calculations */ /* of Pixel to mm */ VRec.Width = VRec.Width-mm / 2.54. /* of Pixel to mm */ /* calc.i Make some calculations */ /* of Pixel to mm */ VRec.Height = VRec.Height-mm / 2.54. /* of Pixel to mm */ /* Rounded Rectangle. */ IF VRec.Rounded THEN RUN vpr_DefRndRect IN THIS-PROCEDURE ( VRec.x-mm , VRec.y-mm , VRec.Width-mm , VRec.Height-mm , VRec.Filled , VRec.BgColour). /* If filled rectangle use standard rectangle */ ELSE IF VRec.Filled THEN RUN vpr_DefRect IN THIS-PROCEDURE ( VRec.x-mm , VRec.y-mm , VRec.Width-mm , VRec.Height-mm , 1 , VRec.BgColour). /* Else build Pseudo-Rectangle to create border. Rectangles with width 1 are lines (from times, lines are not there). */ ELSE DO: /* Top line */ IF NOT VRec.Width = 1 THEN RUN vpr_DefHLine IN THIS-PROCEDURE ( VRec.x-mm , VRec.y-mm , VRec.Width-mm , 0 , VRec.EdgePix , VRec.BgColour ). /* Left line */ IF NOT VRec.Height = 1 THEN RUN vpr_DefVLine IN THIS-PROCEDURE ( VRec.x-mm , VRec.y-mm , VRec.Height-mm , 0 , VRec.EdgePix , VRec.BgColour ). IF VRec.Height > 1 AND VRec.Width > 1 THEN DO: /* Bottom Line */ RUN vpr_DefHLine IN THIS-PROCEDURE ( VRec.x-mm , (VRec.Y-mm + VRec.Height-mm) , VRec.Width-mm , 0 , VRec.EdgePix , VRec.BgColour ). /* Right Line */ RUN vpr_DefVLine IN THIS-PROCEDURE ( (VRec.x-mm + VRec.Width-mm) , VRec.y-mm , VRec.Height-mm , 0 , VRec.EdgePix , VRec.BgColour ). END. END. /* of pseudostriche */ END. /* of for each */ /* This is for Stukki/Imas. */ END PROCEDURE. /* initrect */ /* This one shows all lines which are not group related. */ PROCEDURE vpr_InitLin: /* Bring the Lines in view. */ FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND (VLin.GroupNum = 0 OR VLin.GroupNum = ?): IF VLin.Type = "H" THEN RUN vpr_DefHLine IN THIS-PROCEDURE ( VLin.x-mm , VLin.y-mm , VLin.Len-mm , VLin.Style , VLin.Height-mm , VLin.BgColour ). IF VLin.type = "V" THEN RUN vpr_DefVLine IN THIS-PROCEDURE ( VLin.x-mm , VLin.y-mm , VLin.Len-mm , VLin.Style , VLin.Height-mm , VLin.BgColour ). END. /* of for each Vlin */ END PROCEDURE. /* initlin */ /* Show all images. No matter to what group they belong. */ PROCEDURE vpr_InitImg: /* Bring the images in view. */ FOR EACH VImg WHERE VImg.ReportNum = VReport.Num AND (VImg.GroupNum = 0 OR VImg.GroupNum = ?): FILE-INFO :FILE-NAME = VImg.ImgFile. RUN vpr_DefBMP IN THIS-PROCEDURE ( FILE-INFO :FULL-PATHNAME , VImg.x-mm , VImg.y-mm , VImg.Width-mm , VImg.Height-mm , (IF VImg.Adjust THEN "Resize" ELSE "NoResize") + "," + (IF VImg.Ratio THEN "KeepRatio" ELSE "NoKeepRatio") ). END. /* of for each VImg */ END PROCEDURE. /* initimg */ /* Init all graphical objects. */ PROCEDURE vpr_InitGraphObj: RUN vpr_InitRect. RUN vpr_InitLin. RUN vpr_InitImg. END. /* Setzt eine Gruppe auf eine bestimmte vertikale Position, die relativen Positionen innerhalb der Gruppen bleiben aber erhalten */ PROCEDURE vpr_SetGroupVPosRel: DEF INPUT PARAMETER pp-GroupName AS CHAR NO-UNDO. DEF INPUT PARAMETER pp-VPos AS INT NO-UNDO. DEF VAR l-int AS INT NO-UNDO. DEF VAR l-int2 AS INT NO-UNDO. FIND FIRST VGroup WHERE VGroup.ReportNum = VReport.Num AND VGroup.Name = pp-GroupName NO-ERROR. IF NOT AVAILABLE VGroup THEN RETURN. /* Find y-pos of first cell/text. */ OPEN QUERY q-VObj FOR EACH VObj WHERE VObj.ReportNum = VReport.Num AND VObj.GroupNum = VGroup.Num BY VObj.y-mm. GET FIRST q-VObj. ASSIGN l-Int = VObj.y-mm NO-ERROR. /* Find y-pos of first line. */ OPEN QUERY q-VLin FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND VLin.GroupNum = VGroup.Num BY VLin.y-mm. GET FIRST q-VLin. ASSIGN l-Int2 = VLin.y-mm NO-ERROR. IF AVAILABLE VObj AND AVAILABLE VLin THEN l-Int = MINIMUM(l-int,l-int2). ELSE IF AVAILABLE VLin THEN l-int = l-int2. /* Set the Position. */ DO WHILE AVAIL VObj: ASSIGN VObj.y-mm = VObj.y-mm - l-int + pp-VPos. RUN vpr_SetCellPos IN THIS-PROCEDURE ( VObj.Name, VGroup.Name , VObj.x-mm, VObj.y-mm , VObj.Width-mm, VObj.Height-mm). GET NEXT q-VObj. END. /* Set the Position for Lines. */ DO WHILE AVAIL VLin: ASSIGN VLin.y-mm = VLin.y-mm - l-int + pp-VPos. GET NEXT q-VLin. END. END PROCEDURE. /* SetGroupVPosRel */ /* Nur zum Testen KdV */ PROCEDURE vpr_GetGroups: DEF INPUT PARAMETER p-report AS CHAR NO-UNDO. DEF OUTPUT PARAMETER p-grplst AS CHAR NO-UNDO. DEF BUFFER B-Vrep FOR TEMP-TABLE VrepDef. FIND FIRST B-Vrep WHERE B-Vrep.NAME = p-report NO-ERROR. IF AVAILABLE B-VRep THEN DO: FOR EACH VGroup WHERE VGroup.ReportNum = B-Vrep.Num: p-grplst = p-grplst + "," + VGroup.NAME. END. p-grplst = SUBSTRING(p-grplst,2). END. END PROCEDURE. /* GetGroups */ PROCEDURE vpr_RemoveReport: DEF INPUT PARAM l-RepName AS CHAR NO-UNDO. FOR EACH VReport WHERE VReport.NAME = l-RepName: FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: DELETE VGroup. END. FOR EACH VObj WHERE VObj.ReportNum = VReport.Num: DELETE VObj . END. FOR EACH VLin WHERE VLin.ReportNum = VReport.Num: DELETE VLin . END. FOR EACH VRec WHERE VRec.ReportNum = VReport.Num: DELETE VRec . END. FOR EACH VImg WHERE VImg.ReportNum = VReport.Num: DELETE VImg . END. FOR EACH VLin WHERE VLin.ReportNum = VReport.Num: DELETE VLin . END. DELETE VReport. END. END PROCEDURE. PROCEDURE vpr_RemoveReportNum: DEF INPUT PARAM l-RepNum AS INT NO-UNDO. FOR EACH VReport WHERE VReport.Num = l-RepNum: FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: DELETE VGroup. END. FOR EACH VObj WHERE VObj.ReportNum = VReport.Num: DELETE VObj . END. FOR EACH VLin WHERE VLin.ReportNum = VReport.Num: DELETE VLin . END. FOR EACH VRec WHERE VRec.ReportNum = VReport.Num: DELETE VRec . END. FOR EACH VImg WHERE VImg.ReportNum = VReport.Num: DELETE VImg . END. FOR EACH VLin WHERE VLin.ReportNum = VReport.Num: DELETE VLin . END. DELETE VReport. END. END PROCEDURE. PROCEDURE vpr_SetImgFile: DEF INPUT PARAM l-imgname AS CHAR NO-UNDO. DEF INPUT PARAM l-filename AS CHAR NO-UNDO. FIND FIRST VImg EXCLUSIVE-LOCK WHERE VImg.ReportNum = VReport.Num AND VImg.Name = l-imgname NO-ERROR. IF NOT AVAIL VImg THEN RETURN ERROR. ASSIGN VImg.ImgFile = l-filename. END PROCEDURE. /* * helper to change the linestyles from numbers (funnily used by the designer) * their string names as used by SetGraphObj * * jc, 06.07.05 */ PROCEDURE ip_stylenumber2string: DEFINE INPUT PARAMETER p-style AS INT NO-UNDO. DEFINE OUTPUT PARAMETER p-char AS CHAR NO-UNDO. p-char = "Solid". CASE p-style : WHEN 1 THEN DO: p-char = "dash". END. WHEN 2 THEN DO: p-char = "dot". END. WHEN 3 THEN DO: p-char = "dashdot". END. WHEN 4 THEN DO: p-char = "dashdashdot". END. END CASE. END. /** vfl/vfr IO */ /* File: vfr.i /*taken from filerep.p*/ Author: Klaus Erichsen Purpose: Viper Frame Designer - load/save report(s) from/into work tables ke, ??????; changed coordination system from pixel to 1/10 of mm. But there may reports out which uses old system. So we load the pixel and convert them at the end to 1/10 mm ke, 981121; added images ke, 981121; changed decision to use the old (non mm) values from the x-mm to the with-mm. The x-mm could be 0. ke, 990417; Now also store reports and work as persistent program ke, 990616; Now 16 Fonts allowed ke, 04 nov00; Added the storage/load of the version. But is not in use. bh, 041116; order and private-data Last change: KE 13 Mar 2001 3:38 pm Last change: BH 18 Apr 2002 2:21 pm */ /** PROCEDURE vpr_LoadVFR IN p-LibraryFile AS CHAR NEW PROCEDURE vpr_LoadVFL IN p-ReportFile AS CHAR NEW PROCEDURE vpr_SaveVFR IN p-ReportNum AS INT IN p-FileName AS CHAR NEW PROCEDURE ip-vfrLoadReport IN p-LibraryFile AS CHAR */ /* The version is put in the vfl file to know which version has written the file and to maintain compability for newer versions. */ DEF STREAM s-io. PROCEDURE vpr_LoadVFL: DEF INPUT PARAM p-LibName AS CHAR NO-UNDO. RUN ip-vfrLoadReport (p-libname). END PROCEDURE. PROCEDURE vpr_LoadVFR: DEF INPUT PARAM p-LibName AS CHAR NO-UNDO. RUN ip-vfrLoadReport (p-libname). END PROCEDURE. /** Procedures */ PROCEDURE ip-vfrLoadReport: DEF INPUT PARAM l-LibName AS CHAR NO-UNDO. /* Counter for object types. */ DEF VAR l-RepNum AS INT NO-UNDO. DEF VAR lp-Line AS CHAR NO-UNDO. DEF VAR lp-Key AS CHAR NO-UNDO. DEF VAR lp-Val AS CHAR NO-UNDO. DEF VAR lp-Type AS CHAR NO-UNDO. DEF VAR lp-equal AS INT NO-UNDO. /* Size scope to whole program */ FOR LAST VReport BY VReport.Num: l-repnum = VReport.Num. END. FIND FIRST VGroup NO-ERROR. FIND FIRST VObj NO-ERROR. FIND FIRST VRec NO-ERROR. FIND FIRST VLin NO-ERROR. FIND FIRST VImg NO-ERROR. FIND FIRST VflSetup. VflSetup.Version = "100". /* Open Stream to Report-Library. */ FILE-INFO:FILE-NAME = l-LibName. INPUT STREAM s-io FROM VALUE(FILE-INFO:FULL-PATHNAME). READ-LINE: REPEAT: /* Eine Zeile lesen. */ IMPORT STREAM s-io UNFORMATTED lp-Line. lp-line = TRIM(lp-Line). /* Skip unusable lines. */ IF lp-Line BEGINS ";" THEN NEXT READ-LINE. lp-equal = INDEX(lp-Line, "="). IF lp-equal = 0 THEN NEXT READ-LINE. /* Get key and value. */ ASSIGN lp-key = ENTRY(1, lp-Line, "=") lp-Val = SUBSTR(lp-Line, lp-equal + 1). /* When a new object begins, create an worktable record to hold it. */ IF lp-Key = "BeginObject" THEN CASE lp-Val: /* Settings which may be used to make old reports compatible. */ WHEN "Setup" THEN DO: lp-Type = "Setup". END. WHEN "Report" THEN DO: CREATE VReport. /* The report number must be unique. So we use an variable. */ ASSIGN l-RepNum = l-RepNum + 1 VReport.Num = l-RepNum VReport.ActNum = 1 lp-Type = "Report". END. WHEN "Group" THEN DO: CREATE VGroup. ASSIGN VReport.ActNum = VReport.ActNum + 1 VGroup.Num = VReport.ActNum VGroup.ReportNum = VReport.Num lp-Type = "Group". END. /* of when group */ WHEN "Cell" THEN DO: CREATE VObj. ASSIGN VReport.ActNum = VReport.ActNum + 1 VObj.Num = VReport.ActNum VObj.Type = "Cell" VObj.ReportNum = VReport.Num VObj.GroupNum = VGroup.Num lp-Type = "Cell". END. /* when cell */ WHEN "Text" THEN DO: CREATE VObj. ASSIGN VReport.ActNum = VReport.ActNum + 1 VObj.Num = VReport.ActNum VObj.Type = "Text" VObj.ReportNum = VReport.Num VObj.GroupNum = VGroup.Num lp-Type = "Text". END. /* when cell */ WHEN "Rectangle" THEN DO: CREATE VRec. ASSIGN VReport.ActNum = VReport.ActNum + 1 VRec.Num = VReport.ActNum VRec.ReportNum = VReport.Num VRec.GroupNum = IF AVAILABLE VGroup THEN VGroup.Num ELSE 0 lp-Type = "Rectangle". END. /* of rectangle */ WHEN "Line" THEN DO: CREATE VLin. ASSIGN VReport.ActNum = VReport.ActNum + 1 VLin.Num = VReport.ActNum VLin.ReportNum = VReport.Num VLin.GroupNum = IF AVAILABLE VGroup THEN VGroup.Num ELSE 0 lp-Type = "Line". END. WHEN "Image" THEN DO: CREATE VImg. ASSIGN VReport.ActNum = VReport.ActNum + 1 VImg.Num = VReport.ActNum VImg.ReportNum = VReport.Num VImg.GroupNum = IF AVAILABLE VGroup THEN VGroup.Num ELSE 0 lp-Type = "Image". END. OTHERWISE DO: MESSAGE "Objecttype: " lp-Val " unknown!". END. END. /* of begin object */ /* If the object is complete, store it. */ ELSE IF lp-Key = "EndObject" THEN DO: CASE lp-val: WHEN "Setup" THEN. WHEN "Report" THEN. /* Do nothing special. */ WHEN "Group" THEN DO: RELEASE VGroup. END. WHEN "Cell" THEN DO: /* Create the 1/10 mm values for compability to older saved reports. Hint: the width must be greater then 0. */ IF VObj.Width-mm = 0 THEN ASSIGN VObj.x-mm = VObj.x * 2.54 VObj.y-mm = VObj.y * 2.54 VObj.Width-mm = VObj.Width * 2.54 VObj.Height-mm = VObj.Height * 2.54. END. /* of cell */ WHEN "Text" THEN DO: /* Create the 1/10 mm values for compability to older saved reports. Hint: every position must be greater then 0. */ IF VObj.Width-mm = 0 THEN ASSIGN VObj.x-mm = VObj.x * 2.54 VObj.y-mm = VObj.y * 2.54 VObj.Width-mm = VObj.Width * 2.54 VObj.Height-mm = VObj.Height * 2.54. END. /* of cell */ WHEN "Rectangle" THEN DO: IF VRec.Width-mm = 0 THEN ASSIGN /* compability */ VRec.x-mm = VRec.x * 2.54 VRec.y-mm = VRec.y * 2.54 VRec.Width-mm = VRec.Width * 2.54 VRec.Height-mm = VRec.Height * 2.54. END. /* rectangle */ WHEN "Line" THEN DO: END. WHEN "Image" THEN DO: END. END CASE. lp-Type = "". END. /* of endobject */ /* Go through the object types. */ ELSE CASE lp-Type: /* Load attributes for the vfl setup. */ WHEN "Setup" THEN CASE lp-Key: WHEN "Version" THEN DO: FIND FIRST VflSetup. VflSetup.Version = lp-Val. /* MESSAGE VflSetup.Version. */ END. END. /* Load attributes for a Report. */ WHEN "Report" THEN CASE lp-Key: WHEN "Name" THEN VReport.Name = lp-Val. WHEN "Font1" THEN VReport.FontNam[1] = lp-Val. WHEN "Font2" THEN VReport.FontNam[2] = lp-Val. WHEN "Font3" THEN VReport.FontNam[3] = lp-Val. WHEN "Font4" THEN VReport.FontNam[4] = lp-Val. WHEN "Font5" THEN VReport.FontNam[5] = lp-Val. WHEN "Font6" THEN VReport.FontNam[6] = lp-Val. WHEN "Font7" THEN VReport.FontNam[7] = lp-Val. WHEN "Font8" THEN VReport.FontNam[8] = lp-Val. WHEN "Font9" THEN VReport.FontNam[9] = lp-Val. WHEN "Font10" THEN VReport.FontNam[10] = lp-Val. WHEN "Font11" THEN VReport.FontNam[11] = lp-Val. WHEN "Font12" THEN VReport.FontNam[12] = lp-Val. WHEN "Font13" THEN VReport.FontNam[13] = lp-Val. WHEN "Font14" THEN VReport.FontNam[14] = lp-Val. WHEN "Font15" THEN VReport.FontNam[15] = lp-Val. WHEN "Font16" THEN VReport.FontNam[16] = lp-Val. WHEN "GridWidth" THEN VReport.GridWidth = INT(lp-Val). WHEN "GridHeight" THEN VReport.GridHeight = INT(lp-Val). WHEN "GridVertical" THEN VReport.GridVertical = INT(lp-Val). WHEN "GridHorizontal" THEN VReport.GridHorizontal = INT(lp-Val). WHEN "Width-mm" THEN VReport.Width-mm = INT(lp-Val). WHEN "Height-mm" THEN VReport.Height-mm = INT(lp-Val). WHEN "Portrait" THEN VReport.Portrait = (lp-Val = "yes"). WHEN "Private-Data" THEN VReport.Private-Data = lp-Val. WHEN "Order" THEN VReport.Order = INT(lp-Val). WHEN "Rem" THEN VReport.Rem = REPLACE(lp-Val, CHR(1), CHR(10)). WHEN "PaperType" THEN VReport.PaperType = lp-Val. END. /* of when report */ /* Load attributes for an group. */ WHEN "Group" THEN CASE lp-Key: WHEN "Name" THEN VGroup.Name = lp-Val. WHEN "PreSkip" THEN VGroup.PreSkip = INT(lp-Val). WHEN "PostSkip" THEN VGroup.PostSkip = INT(lp-Val). WHEN "Unit" THEN VGroup.Unit = lp-Val. WHEN "RelPos" THEN VGroup.RelPos = (lp-Val = "yes"). WHEN "Private-Data" THEN VGroup.Private-Data = lp-Val. WHEN "Order" THEN VGroup.Order = INT(lp-Val). END. /* of when group */ /* Load attributes for an cell. */ WHEN "Cell" THEN CASE lp-Key: WHEN "Name" THEN VObj.Name = lp-Val. WHEN "TextValue" THEN VObj.TextValue = lp-Val. WHEN "Alignment" THEN VObj.Align = lp-Val. WHEN "AutoWrap" THEN VObj.Autowrap = lp-val. WHEN "RTFAllow" THEN VObj.RTFAllow = (lp-Val = "yes"). WHEN "AutoResize" THEN VObj.AutoResize = (lp-Val = "yes"). WHEN "FgColour" THEN VObj.FgColour = lp-Val. WHEN "BgColour" THEN VObj.BgColour = lp-Val. WHEN "FontNo" THEN VObj.FontNo = INT(lp-Val). WHEN "X" THEN VObj.x = INT(lp-Val). /* compatibility */ WHEN "Y" THEN VObj.y = INT(lp-Val). WHEN "Width" THEN VObj.Width = INT(lp-Val). WHEN "Height" THEN VObj.Height = INT(lp-Val). WHEN "X-mm" THEN VObj.x-mm = INT(lp-Val). WHEN "Y-mm" THEN VObj.y-mm = INT(lp-Val). WHEN "Width-mm" THEN VObj.Width-mm = INT(lp-Val). WHEN "Height-mm" THEN VObj.Height-mm = INT(lp-Val). WHEN "Private-Data" THEN VObj.Private-Data = lp-Val. WHEN "Order" THEN VObj.Order = INT(lp-Val). WHEN "zOrder" THEN VObj.zOrder = INT(lp-Val). WHEN "KeepText" THEN VObj.KeepText = (lp-Val = "yes"). END. /* of when cell */ /* Load attributes for an text. */ WHEN "Text" THEN CASE lp-Key: WHEN "Name" THEN VObj.Name = lp-Val. WHEN "TextValue" THEN VObj.TextValue = REPLACE(lp-Val, CHR(1), CHR(10)). WHEN "Alignment" THEN VObj.Align = lp-Val. WHEN "AutoWrap" THEN VObj.Autowrap = lp-Val. WHEN "RTFAllow" THEN VObj.RTFAllow = (lp-Val = "yes"). WHEN "AutoResize" THEN VObj.AutoResize = (lp-Val = "yes"). WHEN "FgColour" THEN VObj.FgColour = lp-Val. WHEN "BgColour" THEN VObj.BgColour = lp-Val. WHEN "FontNo" THEN VObj.FontNo = INT(lp-Val). WHEN "X" THEN VObj.x = INT(lp-Val). /* compatibility */ WHEN "Y" THEN VObj.y = INT(lp-Val). WHEN "Width" THEN VObj.Width = INT(lp-Val). WHEN "Height" THEN VObj.Height = INT(lp-Val). WHEN "X-mm" THEN VObj.x-mm = INT(lp-Val). WHEN "Y-mm" THEN VObj.y-mm = INT(lp-Val). WHEN "Width-mm" THEN VObj.Width-mm = INT(lp-Val). WHEN "Height-mm" THEN VObj.Height-mm = INT(lp-Val). WHEN "Private-Data" THEN VObj.Private-Data = lp-Val. WHEN "Order" THEN VObj.Order = INT(lp-Val). WHEN "zOrder" THEN VObj.zOrder = INT(lp-Val). WHEN "KeepText" THEN VObj.KeepText = (lp-Val = "yes"). END. /* of when text */ /* Rectangle attributes. */ WHEN "Rectangle" THEN CASE lp-Key: WHEN "Name" THEN VRec.Name = lp-Val. WHEN "Rounded" THEN VRec.Rounded = (lp-Val = "yes"). WHEN "Filled" THEN VRec.Filled = (lp-Val = "yes"). WHEN "EdgePixels" THEN VRec.EdgePix = INT(lp-Val). WHEN "BgColour" THEN VRec.BgColour = lp-Val. WHEN "X" THEN VRec.x = INT(lp-Val). /* compatibility */ WHEN "Y" THEN VRec.y = INT(lp-Val). WHEN "Width" THEN VRec.Width = INT(lp-Val). WHEN "Height" THEN VRec.Height = INT(lp-Val). WHEN "X-mm" THEN VRec.x-mm = INT(lp-Val). WHEN "Y-mm" THEN VRec.y-mm = INT(lp-Val). WHEN "Width-mm" THEN VRec.Width-mm = INT(lp-Val). WHEN "Height-mm" THEN VRec.Height-mm = INT(lp-Val). WHEN "Private-Data" THEN VRec.Private-Data = lp-Val. WHEN "Order" THEN VRec.Order = INT(lp-Val). WHEN "zOrder" THEN VRec.zOrder = INT(lp-Val). END. /* of when rectangle */ /* Line attributes. */ WHEN "Line" THEN CASE lp-Key: WHEN "Name" THEN VLin.Name = lp-Val. WHEN "Type" THEN VLin.Type = lp-Val. WHEN "Style" THEN VLin.Style = INT(lp-Val). WHEN "X-mm" THEN VLin.x-mm = INT(lp-Val). WHEN "Y-mm" THEN VLin.y-mm = INT(lp-Val). WHEN "Len-mm" THEN VLin.Len-mm = INT(lp-Val). WHEN "Height-mm" THEN VLin.Height-mm = INT(lp-Val). WHEN "BgColour" THEN VLin.BgColour = lp-Val. WHEN "Private-Data" THEN VLin.Private-Data = lp-Val. WHEN "Order" THEN VLin.Order = INT(lp-Val). WHEN "zOrder" THEN VLin.zOrder = INT(lp-Val). END. /* of when line */ /* Image attributes. */ WHEN "Image" THEN CASE lp-Key: WHEN "Name" THEN VImg.Name = lp-Val. WHEN "Adjust" THEN VImg.Adjust = (lp-Val = "yes"). WHEN "Ratio" THEN VImg.Ratio = (lp-Val = "yes"). WHEN "ImgType" THEN VImg.ImgType = lp-Val. WHEN "ImgFile" THEN VImg.ImgFile = lp-Val. WHEN "X-mm" THEN VImg.x-mm = INT(lp-Val). WHEN "Y-mm" THEN VImg.y-mm = INT(lp-Val). WHEN "Width-mm" THEN VImg.Width-mm = INT(lp-Val). WHEN "Height-mm" THEN VImg.Height-mm = INT(lp-Val). WHEN "Private-Data" THEN VImg.Private-Data = lp-Val. WHEN "Order" THEN VImg.Order = INT(lp-Val). WHEN "zOrder" THEN VImg.zOrder = INT(lp-Val). END. /* of when image */ END. /* case lp-type */ END. /* of read-line */ INPUT STREAM s-io CLOSE. END PROCEDURE. /* ip-loadreports */ /* Save all reports. */ PROCEDURE vpr_SaveVFR: DEF INPUT PARAM l-RepNum AS INT NO-UNDO. DEF INPUT PARAM l-LibName AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. /* Define Buffer to know the default values. */ DEF BUFFER b-VReport FOR TEMP-TABLE VReport. CREATE b-VReport. b-VReport.ActNum = -1. /* Hide this to safe */ DEF BUFFER b-VGroup FOR TEMP-TABLE VGroup. CREATE b-VGroup. DEF BUFFER b-VObj FOR TEMP-TABLE VObj. CREATE b-VObj. /* DEF BUFFER b-VLin FOR VLin. CREATE b-VLin. DEF BUFFER b-VRec FOR VRec. CREATE b-VRec. DEF BUFFER b-VImg FOR VImg. CREATE b-VImg. */ DEF VAR lp-fileName AS CHAR NO-UNDO. /* Check if lib exist, then make backup. */ FILE-INFO:FILE-NAME = l-LibName. IF FILE-INFO:FULL-PATHNAME <> ? THEN DO: lp-fileName = FILE-INFO:FULL-PATHNAME. lp-fileName = SUBSTRING(lp-FileName, 1 , R-INDEX(lp-FileName, ".")). OS-RENAME VALUE( FILE-INFO:FULL-PATHNAME ) VALUE( lp-FileName + "bak" ). END. /* of lib avail */ /* Open Stream to Report-Library. */ OUTPUT STREAM s-io TO VALUE(l-LibName). /* Global information. */ PUT STREAM s-io UNFORMATTED SKIP ";This file is generated by Viper Designer" SKIP ";Document Version 202" SKIP ";Program authors: lb, bh, jc, ke, IAP GmbH, Moerkenstr. 9, 22767 Hamburg, Germany" SKIP ";Info and updates at: http://tools4progress.com or http://www.iap.de" SKIP ";Or telephone: +49 + 40 - 30 68 03 - 0" SKIP(1) ";It is possible (and sometimes useful) to change something in this file," SKIP ";but be carefull (and clever) and make a backup copy before." SKIP(1) ";And, by the way: Lines beginning with an ';' will be ignored ;-)" . /* Put version information in file. */ PUT STREAM s-io UNFORMATTED SKIP(2) "BeginObject=Setup" SKIP " Version=202" SKIP "EndObject=Setup" . /* Save report header. */ FOR EACH VReport WHERE VReport.Num = l-RepNum AND VReport.ActNum > 0: PUT STREAM s-io UNFORMATTED SKIP (2) SKIP "BeginObject=Report" SKIP " Name=" VReport.NAME. /* SKIP " ActNum=" VReport.ActNum */ DO ii = 1 TO 16: IF b-VReport.FontNam[ii] <> VReport.FontNam[ii] THEN PUT STREAM s-io UNFORMATTED SKIP " Font" ii "=" VReport.FontNam[ii]. END. /* remarks to the report. Could not be done from savend.i */. IF b-VReport.Rem <> VReport.Rem THEN PUT STREAM s-io UNFORMATTED SKIP " Rem=" REPLACE(VReport.Rem, CHR(10), CHR(1)). /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP ' GridWidth=' VReport.GridWidth. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.GridHeight <> VReport.GridHeight THEN PUT STREAM s-io UNFORMATTED SKIP ' GridHeight=' VReport.GridHeight. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.GridVertical <> VReport.GridVertical THEN PUT STREAM s-io UNFORMATTED SKIP ' GridVertical=' VReport.GridVertical. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.GridHorizontal <> VReport.GridHorizontal THEN PUT STREAM s-io UNFORMATTED SKIP ' GridHorizontal=' VReport.GridHorizontal. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.Width-mm <> VReport.Width-mm THEN PUT STREAM s-io UNFORMATTED SKIP ' Width-mm=' VReport.Width-mm. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.Height-mm <> VReport.Height-mm THEN PUT STREAM s-io UNFORMATTED SKIP ' Height-mm=' VReport.Height-mm. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.Portrait <> VReport.Portrait THEN PUT STREAM s-io UNFORMATTED SKIP ' Portrait=' VReport.Portrait. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.Private-Data <> VReport.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VReport.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.Order <> VReport.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VReport.Order. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VReport.PaperType <> VReport.PaperType THEN PUT STREAM s-io UNFORMATTED SKIP ' PaperType=' VReport.PaperType. /* Save groups of report. */ FOR EACH VGroup WHERE VGroup.ReportNum = VReport.Num: PUT STREAM s-io UNFORMATTED SKIP(1) " BeginObject=Group" SKIP " Name=" VGroup.NAME. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.PreSkip <> VGroup.PreSkip THEN PUT STREAM s-io UNFORMATTED SKIP ' PreSkip=' VGroup.PreSkip. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.PostSkip <> VGroup.PostSkip THEN PUT STREAM s-io UNFORMATTED SKIP ' PostSkip=' VGroup.PostSkip. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.Unit <> VGroup.Unit THEN PUT STREAM s-io UNFORMATTED SKIP ' Unit=' VGroup.Unit. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.RelPos <> VGroup.RelPos THEN PUT STREAM s-io UNFORMATTED SKIP ' RelPos=' VGroup.RelPos. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.Private-Data <> VGroup.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VGroup.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VGroup.Order <> VGroup.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VGroup.Order. /* Save cell objects of group. */ FOR EACH VObj WHERE VObj.ReportNum = VReport.Num AND VObj.GroupNum = VGroup.Num: /* The Text from the TextValue could have more than one line. So convert the LFs int the string to hx002 */ PUT STREAM s-io UNFORMATTED SKIP(1) IF VObj.Type = "Cell" THEN " BeginObject=Cell" ELSE " BeginObject=Text" SKIP " Name=" VObj.Name /* Save measures as 1/10 mm now. */ SKIP " X-mm=" VObj.x-mm SKIP " Y-mm=" VObj.y-mm SKIP " Width-mm=" VObj.Width-mm SKIP " Height-mm=" VObj.Height-mm . IF b-VObj.TextValue <> VObj.TextValue THEN PUT STREAM s-io UNFORMATTED SKIP " TextValue=" REPLACE(VObj.TextValue, CHR(10), CHR(1)). /* To get old saved values to default */ IF VObj.Align = "" THEN VObj.Align = "Left". IF VObj.Autowrap = "" THEN VObj.Autowrap = "FALSE". /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.Align <> VObj.Align THEN PUT STREAM s-io UNFORMATTED SKIP ' Alignment=' VObj.Align. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.Autowrap <> VObj.Autowrap THEN PUT STREAM s-io UNFORMATTED SKIP ' Autowrap=' VObj.Autowrap. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.RTFAllow <> VObj.RTFAllow THEN PUT STREAM s-io UNFORMATTED SKIP ' RTFAllow=' VObj.RTFAllow. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.AutoResize <> VObj.AutoResize THEN PUT STREAM s-io UNFORMATTED SKIP ' AutoResize=' VObj.AutoResize. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.FgColour <> VObj.FgColour THEN PUT STREAM s-io UNFORMATTED SKIP ' FgColour=' VObj.FgColour. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.BgColour <> VObj.BgColour THEN PUT STREAM s-io UNFORMATTED SKIP ' BgColour=' VObj.BgColour. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.FontNo <> VObj.FontNo THEN PUT STREAM s-io UNFORMATTED SKIP ' FontNo=' VObj.FontNo. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.Private-Data <> VObj.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VObj.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.Order <> VObj.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VObj.Order. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.zOrder <> VObj.zOrder THEN PUT STREAM s-io UNFORMATTED SKIP ' zOrder=' VObj.zOrder. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VObj.KeepText <> VObj.KeepText THEN PUT STREAM s-io UNFORMATTED SKIP ' KeepText=' VObj.KeepText. PUT STREAM s-io UNFORMATTED SKIP IF VObj.Type = "Cell" THEN " EndObject=Cell" ELSE " EndObject=Text". END. /* of for each obj of group */ /* Save grouped rectangle objects. */ FOR EACH VRec WHERE VRec.ReportNum = VReport.Num AND VRec.GroupNum = VGroup.Num: RUN ip-writeCurrentVRec. END. /* of for save rectangles */ /* Save grouped image objects. */ FOR EACH VImg WHERE VImg.ReportNum = VReport.Num AND VImg.GroupNum = VGroup.Num: RUN ip-writeCurrentVImg. END. /* of for save images */ /* Save Line objects that are belonging to a group. */ FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND VLin.GroupNum = VGroup.Num: RUN ip-writeCurrentVLin. END. /* of for save lines */ /* write end of group marker */ PUT STREAM s-io UNFORMATTED SKIP(1) " EndObject=Group". END. /* of for each group of report */ /* * save object that aren't part of a group */ /* Save Rectangle objects. */ FOR EACH VRec WHERE VRec.ReportNum = VReport.Num AND VRec.GroupNum = 0: RUN ip-writeCurrentVRec. END. /* of for save rectangles */ /* Save Image objects. */ FOR EACH VImg WHERE VImg.ReportNum = VReport.Num AND VImg.GroupNum = 0: RUN ip-writeCurrentVImg. END. /* of for save images */ /* Save Line objects. */ FOR EACH VLin WHERE VLin.ReportNum = VReport.Num AND VLin.GroupNum = 0: RUN ip-writeCurrentVLin. END. /* of for save lines */ PUT STREAM s-io UNFORMATTED SKIP(1) "EndObject=Report". END. /* of for each report. */ PUT STREAM s-io UNFORMATTED SKIP(1). OUTPUT STREAM s-io CLOSE. /* Delete buffer for default values */ DELETE b-VReport. DELETE b-VGroup. DELETE b-VObj. /* DELETE b-VLin. DELETE b-VRec. DELETE b-VImg.*/ END PROCEDURE . /* ip-savereports */ PROCEDURE ip-writeCurrentVImg: DEF BUFFER b-VImg FOR TEMP-TABLE VImg. CREATE b-VImg. PUT STREAM s-io UNFORMATTED SKIP(1) " BeginObject=Image" SKIP " Name=" VImg.Name SKIP " ImgFile=" VImg.ImgFile /* Save measures as 1/10 mm now. */ SKIP " X-mm=" VImg.x-mm SKIP " Y-mm=" VImg.y-mm SKIP " Width-mm=" VImg.Width-mm SKIP " Height-mm=" VImg.Height-mm . /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.Adjust <> VImg.Adjust THEN PUT STREAM s-io UNFORMATTED SKIP ' Adjust=' VImg.Adjust. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.Ratio <> VImg.Ratio THEN PUT STREAM s-io UNFORMATTED SKIP ' Ratio=' VImg.Ratio. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.ImgType <> VImg.ImgType THEN PUT STREAM s-io UNFORMATTED SKIP ' ImgType=' VImg.ImgType. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.Private-Data <> VImg.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VImg.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.Order <> VImg.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VImg.Order. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VImg.zOrder <> VImg.zOrder THEN PUT STREAM s-io UNFORMATTED SKIP ' zOrder=' VImg.zOrder. PUT STREAM s-io UNFORMATTED SKIP " EndObject=Image". DELETE b-VImg. END PROCEDURE. PROCEDURE ip-writeCurrentVRec: DEF BUFFER b-VRec FOR TEMP-TABLE VRec. CREATE b-VRec. PUT STREAM s-io UNFORMATTED SKIP(1) " BeginObject=Rectangle" SKIP " Name=" VRec.Name /* Save measures as 1/10 mm now. */ SKIP " X-mm=" VRec.x-mm SKIP " Y-mm=" VRec.y-mm SKIP " Width-mm=" VRec.Width-mm SKIP " Height-mm=" VRec.Height-mm . /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.Rounded <> VRec.Rounded THEN PUT STREAM s-io UNFORMATTED SKIP ' Rounded=' VRec.Rounded. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.Filled <> VRec.Filled THEN PUT STREAM s-io UNFORMATTED SKIP ' Filled=' VRec.Filled. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.EdgePix <> VRec.EdgePix THEN PUT STREAM s-io UNFORMATTED SKIP ' EdgePixels=' VRec.EdgePix. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.BgColour <> VRec.BgColour THEN PUT STREAM s-io UNFORMATTED SKIP ' BgColour=' VRec.BgColour. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.Private-Data <> VRec.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VRec.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.Order <> VRec.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VRec.Order. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VRec.zOrder <> VRec.zOrder THEN PUT STREAM s-io UNFORMATTED SKIP ' zOrder=' VRec.zOrder. PUT STREAM s-io UNFORMATTED SKIP " EndObject=Rectangle". DELETE b-VRec. END PROCEDURE. PROCEDURE ip-writeCurrentVLin: DEF BUFFER b-VLin FOR TEMP-TABLE VLin. CREATE b-VLin. PUT STREAM s-io UNFORMATTED SKIP(1) " BeginObject=Line" SKIP " Name=" VLin.Name SKIP " X-mm=" VLin.x-mm SKIP " Y-mm=" VLin.y-mm SKIP " Len-mm=" VLin.Len-mm SKIP " Height-mm=" VLin.Height-mm . /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.BgColour <> VLin.BgColour THEN PUT STREAM s-io UNFORMATTED SKIP ' BgColour=' VLin.BgColour. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.Type <> VLin.Type THEN PUT STREAM s-io UNFORMATTED SKIP ' Type=' VLin.Type. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.Style <> VLin.Style THEN PUT STREAM s-io UNFORMATTED SKIP ' Style=' VLin.Style. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.Private-Data <> VLin.Private-Data THEN PUT STREAM s-io UNFORMATTED SKIP ' Private-Data=' VLin.Private-Data. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.Order <> VLin.Order THEN PUT STREAM s-io UNFORMATTED SKIP ' Order=' VLin.Order. /* File: savend.i (Save no default values). Author: Klaus Erichsen Parameter: {1}: Buffer name {2}: Field name {3}: Attribute text Example of command: IF b-VReport.GridWidth <> VReport.GridWidth THEN PUT STREAM s-io UNFORMATTED SKIP " GridWidth=" VReport.GridWidth. Last change: KE 19 Aug 2000 4:16 pm */ IF b-VLin.zOrder <> VLin.zOrder THEN PUT STREAM s-io UNFORMATTED SKIP ' zOrder=' VLin.zOrder. PUT STREAM s-io UNFORMATTED SKIP " EndObject=Line". DELETE b-VLin. END PROCEDURE. /** [ PROCEDURE ip-SetAttribut IN p-Attrib AS CHAR IN p-Value AS CHAR old PROCEDURE ip-GetAttribut: IN p-Attrib AS CHAR OUT p-Value AS CHAR old ] */ /* Set/Get attributes. */ PROCEDURE ip-SetAttribut: DEF INPUT PARAM pp-Attrib AS CHAR NO-UNDO. DEF INPUT PARAM pp-Value AS CHAR NO-UNDO. CASE pp-Attrib: /* WHEN "LibName" THEN l-LibName = pp-Value.*/ WHEN "ReportName" THEN l-RepName = pp-Value. WHEN "TestMode" THEN l-testmode = TRUE. OTHERWISE MESSAGE "Unknown Attribute: " pp-Attrib. END CASE. END PROCEDURE. /* ip-setreport */ PROCEDURE ip-GetAttribut: DEF INPUT PARAM pp-Attrib AS CHAR NO-UNDO. DEF OUTPUT PARAM pp-Value AS CHAR NO-UNDO. CASE pp-Attrib: WHEN "Nothing" THEN pp-Value = "Nothing". OTHERWISE MESSAGE "Unknown Attribute: " pp-Attrib. END CASE. END PROCEDURE. /* ip-GetAttribut */ /** xml IO */ /** dump/load IO */ /** dirext DB IO */ /** Basic Viper API */ /* * Name : Viper.i * System: MS-Windows 3.x * Copyright: IAP 1997 * Author: nj, ke, jc * Purpose: This librara is included in viper.p, it declares the external * procedures which are in the dll. * * ke, 15.05.97; added vpprintmode, vpsetcellwrap * jc, 20.08.97; added VpShowPreview,VpHidePreview,VpSetCellColor * jc, 28.08.97; error handling * jc, late 20th century: i guess a lot of stuff has happened in the * meantime, may or may not be seen in viper.p. :) * jc, 19.01.98: added VpEndDoc, VpSet/GetGroupVPos,VpGetCellH/VPos * jc, 04.02.98: added VpSetCellRTF * jc, 07.04.98: VpSetPrinterAttrib * jc, 27.04.98: VpDebug * jc, 29.04.98: VpOpenDoc, VpSaveDoc * jc, 29.05.98: VpGetPrinterAttrib * jc, 24.06.98: VpSaveClipboardToFile * jc, 26.06.98: VpSaveWindowToFile * jc, 13.11.98: VpSetCellSplit * jc, 23.11.98: VpGetCellLineCount, VpShowDLLVersion * jc, 10.12.98: VpSetCellBuffer, VpAddToCellBuffer, VpSubmitCellBuffer, VpDeleteCellBuffer * jc, 11.02.99: VpSetWindowPos * jc, xx.xx.99 and xx.xx.00: Some more stuff, see the function headers for details... * jc, 10.07.2000: VpSetCellLineSpacing, GetCellWidth * jc, 17.08.2000: VpPS2PDF * jc, 15.02.2001: VpGetCellHeight * jc, 03.07.2001: VpSetPaperSize * jc, 04.10.2001: VpSetDocTitle Last change: BH 26 Mar 2002 5:56 pm * jc, 23.08.2002: VpExportDoc * jc,bh, 27.02.2003: VpShowDoc * jc 15.03.2003: VpGetPreviewStatus * jc 12.06.03 _VpGetDefaultPrinter * bh 06.10.04 OUTPUT changed to INPUT-OUTPUT due to 10.B 4GL Issue with DLL calls * jc 21.02.05 VpDebugDumpDocument * jc 25.04.05 VpSetPageVPos * jc 03.05.05 VpSetDocAttrib * jc 13.05.05 VpSetGraphObj * jc 26.05.05 VpSetGroupAttr * jc 27.05.05 VpSetGraphObjAttr */ /* Preprocessor-defines */ /* needs {&VDLL} , e.g. SCOPED-DEFINE VDLL "viper01.dll" */ /* Now define the Internal procedures to wrap the dll-calls. */ PROCEDURE VpSetCell EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. /* always case-sensitive */ DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* dito */ DEF INPUT PARAM p-action AS CHAR NO-UNDO. /* "Create" | "Destroy" (not case-sens.) */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpText EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetDelimiter EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-del AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetGroupText EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF INPUT PARAM p-texts AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetRect EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetFont EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-format AS SHORT NO-UNDO. /* 1=italic,2=underline,4=strikeout,8=bold */ DEF INPUT PARAM p-family AS SHORT NO-UNDO. /* font-family (0 if no altern.) */ DEF INPUT PARAM p-fontName AS CHAR NO-UNDO. /* e.g. "Arial", "TimesNewRoman",... */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetResize EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-dynamic AS SHORT NO-UNDO. /* 0 = static / 1 = dynamic cell */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetCellWrap EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. /* always case-sensitive */ DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* dito */ DEF INPUT PARAM p-Mode AS SHORT NO-UNDO. /* 0 = noWrap 1 = Wrap */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetGroupSkip EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* */ DEF INPUT PARAM p-pre AS SHORT NO-UNDO. /* SKIP vor der group */ DEF INPUT PARAM p-post AS SHORT NO-UNDO. /* SKIP nach der group */ DEF INPUT PARAM p-point AS SHORT NO-UNDO. /* 0 = 0,1mm 1 = POINTS */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpFlushGroup EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpNewPage EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* prints (view) from page to page */ PROCEDURE VpPrint EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-from AS SHORT NO-UNDO. DEF INPUT PARAM p-to AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetJustify EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-type AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpDeleteAll EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-dummy AS SHORT NO-UNDO. END. /********************************************** gfx-support ***/ PROCEDURE VpFreeLine EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF INPUT PARAM p-style AS SHORT NO-UNDO. DEF INPUT PARAM p-bwidth AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. /* col is RGB (bitfield) */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpRectangle EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF INPUT PARAM p-filled AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpRoundRect EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF INPUT PARAM p-filled AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpHLine EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-len AS SHORT NO-UNDO. DEF INPUT PARAM p-style AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpVLine EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-len AS SHORT NO-UNDO. DEF INPUT PARAM p-style AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpHSep EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-len AS SHORT NO-UNDO. DEF INPUT PARAM p-justify AS SHORT NO-UNDO. DEF INPUT PARAM p-style AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-col AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /************************************************* end of gfx-support ***/ /************************************************ get property-values ***/ PROCEDURE VpCellHeight EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-height AS SHORT NO-UNDO. /* DEF RETURN PARAM p-err AS SHORT NO-UNDO. */ END. PROCEDURE VpGroupHeight EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-height AS SHORT NO-UNDO. /* DEF RETURN PARAM p-err AS SHORT NO-UNDO. */ END. PROCEDURE VpGetFree EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-space AS SHORT NO-UNDO. END. PROCEDURE VpGetPages EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-pages AS SHORT NO-UNDO. END. PROCEDURE VpGetPos EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-pos AS SHORT NO-UNDO. END. PROCEDURE VpBitmap EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-Name AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS SHORT NO-UNDO. DEF INPUT PARAM p-y AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF INPUT PARAM p-adjust AS SHORT NO-UNDO. DEF INPUT PARAM p-ratio AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /**********************************************\ |* Printer Auswahl Sachen (PAS) *| |* first: select printer by name *| |* second: printer dialog box *| \**********************************************/ PROCEDURE VpSelectPrinter EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-Name AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpPrinterSetup EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpPrinterDialog EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-Button AS SHORT NO-UNDO. END. /****** Show and hide the preview window ***/ PROCEDURE VpShowPreview EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpHidePreview EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /**** End of showing and hiding the window. */ PROCEDURE VpSetCellColor EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-textc AS long NO-UNDO. DEF INPUT PARAM p-backc AS long NO-UNDO. DEF INPUT PARAM p-bkmode AS short NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /****** Some setups for printing ***/ PROCEDURE VpPrintOptions EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-Mode AS CHAR NO-UNDO. DEF INPUT PARAM p-i1 AS SHORT NO-UNDO. DEF INPUT PARAM p-i2 AS SHORT NO-UNDO. DEF INPUT PARAM p-i3 AS SHORT NO-UNDO. DEF INPUT PARAM p-c1 AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /**** End of setups for printing. */ /************************************** end of get-properties ***/ PROCEDURE ReadErrors EXTERNAL "viper32.dll" CDECL : DEF INPUT-OUTPUT PARAM p-lasterr AS SHORT NO-UNDO. /* last error-no. */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. /* number of errors occured */ END. /************************************ internal (private) ***/ /* start viper.exe */ PROCEDURE StartViper EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM loaded AS SHORT NO-UNDO. END. /* reset data of DLL */ PROCEDURE ClearDLL EXTERNAL "viper32.dll" CDECL : END. /* close viper.exe */ /* clean-up */ PROCEDURE CloseViper EXTERNAL "viper32.dll" CDECL : END. /* 19.01.98 */ /* VpSetGroupVPos - set vertical group position 19.01.98 jpc */ PROCEDURE VpSetGroupVPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-VPos AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpGetCellVPos - get vertical cell position 19.01.98 jpc */ PROCEDURE VpGetCellVPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF RETURN PARAM p-VPos AS SHORT NO-UNDO. END. /* VpGetCellHPos - get vertical cell position 19.01.98 jpc */ PROCEDURE VpGetCellHPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF RETURN PARAM p-HPos AS SHORT NO-UNDO. END. /* VpGetGroupVPos - get vertical group position 19.01.98 jpc */ PROCEDURE VpGetGroupVPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-VPos AS SHORT NO-UNDO. END. /* VpEndDoc - tell viper that it's over... 19.01.98 jpc */ PROCEDURE VpEndDoc EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* 04.02.98 */ /* VpSetCellRTF - set a cell to RTF mode 04.02.98 jpc */ PROCEDURE VpSetCellRTF EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF INPUT PARAM p-rtf AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* 07.04.98 */ /* VpSetPrinterAttrib - sets a couple of printerattributes 07.04.98 jpc */ PROCEDURE VpSetPrinterAttrib EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-PrinterAttrib AS MEMPTR. DEF INPUT PARAM p-duplex AS SHORT NO-UNDO. END. /* 27.04.98 */ /* VpDebug - call some debug helpers 27.04.98 jpc */ PROCEDURE VpDEBUG EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-command AS CHAR NO-UNDO. DEF INPUT PARAM p-parameter AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* 29.04.98 */ /* VpSaveDoc - save a viper document 29.04.98 jpc */ PROCEDURE VpSaveDoc EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-sFileName AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpOpenDoc - load a viper document 29.04.98 jpc */ PROCEDURE VpOpenDoc EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-sFileName AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpGetPrinterAttrib - Get a given printer attrib 28.05.98 jpc */ PROCEDURE VpGetPrinterAttrib EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-attrib AS CHAR NO-UNDO. DEF RETURN PARAM p-value AS SHORT NO-UNDO. END. /* VpSaveClipboardToFile - 24.06.98 jpc */ PROCEDURE VpSaveClipboardToFile EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM DataType AS SHORT NO-UNDO. DEF INPUT PARAM FileNameIn AS CHAR NO-UNDO. /* bug in 10.0B */ DEF INPUT-OUTPUT PARAM FileNameOut AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSaveWindowToFile - 26.06.98 jpc */ PROCEDURE VpSaveWindowToFile EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM wind AS LONG NO-UNDO. DEF INPUT PARAM AreaType AS SHORT NO-UNDO. DEF INPUT PARAM FileNameIn AS CHAR NO-UNDO. /* bug in 10.0B */ DEF INPUT-OUTPUT PARAM FileNameOut AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSetGroupCellPositioning - at FlushGroup: OneLine=0 (default - like previous viper) Relative=1 (retains the relative positions of the cells in a group) 24.09.98 jpc */ PROCEDURE VpSetGroupCellPositioning EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-Style AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSetCellSplit - Set if the Cell should split the cells' text between several "instances" of a cell (i.e. allow cell to support "page break" text 13.11.98 jpc */ PROCEDURE VpSetCellSplit EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-split AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpGetCellLineCount - Get number of linesin a cell 23.11.98 jpc */ PROCEDURE VpGetCellLineCount EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF RETURN PARAM p-LineCount AS SHORT NO-UNDO. END. /* VpShowDLLVersion - Show a messagebox w/ compile date & time 23.11.98 jpc */ PROCEDURE VpShowDLLVersion EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-ver AS SHORT NO-UNDO. END. /* VpSetCellBuffer - Set text in a cells buffer 10.12.98 jpc */ PROCEDURE VpSetCellBuffer EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpAddToCellBuffer - Add text to a cells buffer 10.12.98 jpc */ PROCEDURE VpAddToCellBuffer EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSubmitCellBuffer - Submit the buffer to the CellText i.e. Set the cells text to the text stored in the buffer 10.12.98 jpc */ PROCEDURE VpSubmitCellBuffer EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpDeleteCellBuffer - Empties the cells buffer 10.12.98 jpc */ PROCEDURE VpDeleteCellBuffer EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSetWindowPos - setPosition of Viper window 11.02.99 jpc */ PROCEDURE VpSetWindowPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-left AS SHORT NO-UNDO. DEF INPUT PARAM p-top AS SHORT NO-UNDO. DEF INPUT PARAM p-width AS SHORT NO-UNDO. DEF INPUT PARAM p-height AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpShowCellStatus - ShowStatus of a cell 29.03.99 jpc */ /* PROCEDURE VpShowCellStatus EXTERNAL {&VDLL} CDECL {&PST}: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. */ /* VpSetCurrentPageProperties 27.08.99 jpc */ PROCEDURE VpSetCurrentPageProperties EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-prop AS CHAR NO-UNDO. DEF INPUT PARAM p-value AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* VpSetWindowPosCCI 02.09.1999 jpc */ PROCEDURE VpSetWindowPosCCI EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-hwnd AS LONG NO-UNDO. DEF INPUT PARAM p-x AS LONG NO-UNDO. DEF INPUT PARAM p-y AS LONG NO-UNDO. DEF INPUT PARAM p-cx AS LONG NO-UNDO. DEF INPUT PARAM p-cy AS LONG NO-UNDO. DEF INPUT PARAM p-flags AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpWebPrintDoc - printdoc to webpage * 07.01.2000 jc */ PROCEDURE VpWebPrintDoc EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-from AS SHORT NO-UNDO. DEF INPUT PARAM p-to AS SHORT NO-UNDO. DEF INPUT PARAM p-prt AS CHAR NO-UNDO. /* bug in 10.0B */ DEF INPUT-OUTPUT PARAM fOut AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpSetLandscapePS - set landscape flag in a PS file * 28.06.2000 jc */ PROCEDURE VpSetLandscapePS EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-filePS AS CHAR NO-UNDO. DEF INPUT PARAM p-force AS SHORT NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpSetCellLineSpacing - set the spacing between the lines of a cell * 10.07.2000 jc */ PROCEDURE VpSetCellLineSpacing EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-spass AS DOUBLE NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpGetCellWidth - get the width of a cell. * 10.07.2000 jc */ PROCEDURE VpGetCellWidth EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpPS2PDF - to avoid problems with the length of the commandline and * the size of the environment we have to call ghostscript * from the dll * 17.8.2000 jc */ PROCEDURE VpPS2PDF EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-gsexe AS CHAR NO-UNDO. DEF INPUT PARAM p-gsdir AS CHAR NO-UNDO. DEF INPUT PARAM p-fontpath AS CHAR NO-UNDO. DEF INPUT PARAM p-options AS CHAR NO-UNDO. DEF INPUT PARAM p-options2 AS CHAR NO-UNDO. DEF INPUT PARAM p-device AS CHAR NO-UNDO. DEF INPUT PARAM p-infile AS CHAR NO-UNDO. DEF INPUT PARAM p-outfile AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpDumpCellReadable - a pure debugging function, that dumps the * parsed cell text in a readable format into a given file * pars: cellname * groupname * filename * filemode: "w"=write, delete old file, "a"=append to exosting file * * 01.11.2000 jc */ PROCEDURE VpDumpCellReadable EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-fname AS CHAR NO-UNDO. DEF INPUT PARAM p-mode AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpSetCellHeight - Set the height of a cell without touching its position * should have been done much earlier :-) * * 15.02.2001 jc */ PROCEDURE VpSetCellHeight EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpSetPaperSize - Set the current paper size * * 03.07.2001 jc */ PROCEDURE VpSetPaperSize EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-width AS LONG NO-UNDO. DEF INPUT PARAM p-height AS LONG NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpSetDocTitle - Set the current documents title * * 04.10.2001 jc */ PROCEDURE VpSetDocTitle EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-title AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * export xslfo * * 23.08.02 jc */ PROCEDURE VpExportDoc EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-from AS LONG NO-UNDO. DEF INPUT PARAM p-to AS LONG NO-UNDO. DEF INPUT PARAM p-fnam AS CHAR NO-UNDO. DEF INPUT PARAM p-type AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * Create a persistent preview, that outlives the DLL/viper handle * * 27.02.03 jc */ PROCEDURE VpShowDoc EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * Return the current preview status (hidden/visible) * * 15.03.03 jc */ PROCEDURE VpGetPreviewStatus EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-wait AS SHORT NO-UNDO. DEF RETURN PARAM p-status AS SHORT NO-UNDO. END. /* * Get the current default printer * * this is no official part of the API * 12.06.03 jc */ PROCEDURE _VpGetDefaultPrinter EXTERNAL "viper32.dll" CDECL : DEF RETURN PARAMETER p-name AS MEMPTR NO-UNDO. END. /* * Set the default printer * * this is no official part of the API * 12.06.03 jc */ PROCEDURE _VpSetDefaultPrinter EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAMETER p-name AS CHAR. DEF RETURN PARAMETER p-ret AS LONG. END. /* * Set a codepage for the given cell * this is only preliminary * 12.11.04 jc */ PROCEDURE VpSetCellCodePage EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. /* always case-sensitive */ DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* dito */ DEF INPUT PARAM p-CP AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * Dump the current contents of the document * currently this only dumps the cells (see OnePage::DebugDumpToFile) * 21.02.05 jc */ PROCEDURE VpDebugDumpDocument EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-fnam AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS LONG NO-UNDO. END. /* * VpSetPageVPos: set the current position for the current page * * 25.04.05 jc */ PROCEDURE VpSetPageVPos EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-pos AS LONG NO-UNDO. DEF RETURN PARAM p-err AS LONG NO-UNDO. END. /* * VpSetDocAttrib: set attributes for the document * e.g. CREATEMODE * * 03.05.05 jc */ PROCEDURE VpSetDocAttrib EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-attriblist AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS LONG NO-UNDO. END. /* * _VpSetGsParams * set ghostscript parameters. this is used for the * printPDF button of the preview and should be called on * startup of viper * 03.05.05 jc */ PROCEDURE _VpSetGsParams EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-gsexe AS CHAR NO-UNDO. DEF INPUT PARAM p-gsdir AS CHAR NO-UNDO. DEF INPUT PARAM p-fontpath AS CHAR NO-UNDO. DEF INPUT PARAM p-options AS CHAR NO-UNDO. DEF INPUT PARAM p-options2 AS CHAR NO-UNDO. DEF INPUT PARAM p-device AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* * VpGetCellTextHeight * returns the height the whole text of the cell would need * to be displayed. this is identical to getcellheight for cell * that automatically resize * 04.05.05 jc */ PROCEDURE VpGetCellTextHeight EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-height AS SHORT NO-UNDO. END. /* * VpGetCellTextWidth * returns the width the cells' text needs to display * without more linebreaking, than currently used * 04.05.05 jc */ PROCEDURE VpGetCellTextWidth EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF RETURN PARAM p-height AS SHORT NO-UNDO. END. /* * VpSetGraphObj * sets group based grahical objects: BMP, RECT, etc. * 13.05.05 jc */ PROCEDURE VpSetGraphObj EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-objnam AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-type AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS LONG NO-UNDO. DEF INPUT PARAM p-y AS LONG NO-UNDO. DEF INPUT PARAM p-w AS LONG NO-UNDO. DEF INPUT PARAM p-h AS LONG NO-UNDO. DEF INPUT PARAM p-attribs AS CHAR NO-UNDO. DEF RETURN PARAM p-err AS LONG NO-UNDO. END PROCEDURE. /* * VpSetGroupAttr * sets group attributes from a key/value list * 26.05.05 jc */ PROCEDURE VpSetGroupAttr EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE INPUT PARAM p-attr AS CHAR NO-UNDO. DEFINE RETURN PARAM p-err AS LONG NO-UNDO. END PROCEDURE. /* * VpSetGraphObjAttr * sets GraphObj attributes from a key/value list * 27.05.05 jc */ PROCEDURE VpSetGraphObjAttr EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-object AS CHAR NO-UNDO. DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE INPUT PARAM p-attr AS CHAR NO-UNDO. DEFINE RETURN PARAM p-err AS LONG NO-UNDO. END PROCEDURE. /* * VpGetGroupHPos * retrieves the horizontal position of the bounding rectangle of a group * 03.08.06 jc */ PROCEDURE VpGetGroupHPos EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE RETURN PARAM p-err AS LONG NO-UNDO. END PROCEDURE. /* * VpGetGroupWidth * retrieves the width of the bounding rectangle of a group * 03.08.06 jc */ PROCEDURE VpGetGroupWidth EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE RETURN PARAM p-err AS LONG NO-UNDO. END PROCEDURE. /* * VpGetGroupObjects * retrieve a comma separated list of the objects in the given group * 04.05.07 jc */ PROCEDURE VpGetGroupObjects EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE INPUT PARAM p-type AS CHAR NO-UNDO. DEFINE RETURN PARAM p-res AS MEMPTR NO-UNDO. END PROCEDURE. /* * VpSetCellRotation * sets the rotation angle for the cell's text. * counterclockwise * june/july 2011 jc */ PROCEDURE VpSetCellRotation EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAM p-object AS CHAR NO-UNDO. DEFINE INPUT PARAM p-group AS CHAR NO-UNDO. DEFINE INPUT PARAM p-angle AS DOUBLE NO-UNDO. DEFINE RETURN PARAM p-err AS LONG NO-UNDO. END. /* * VpSetCellFont * set the cell font. supersedes VpSetFont * Aug 15, 2011 jc */ PROCEDURE VpSetCellFont EXTERNAL "viper32.dll" CDECL : DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS FLOAT NO-UNDO. DEF INPUT PARAM p-width AS FLOAT NO-UNDO. DEF INPUT PARAM p-format AS SHORT NO-UNDO. /* 1=italic,2=underline,4=strikeout,8=bold */ DEF INPUT PARAM p-family AS SHORT NO-UNDO. /* font-family (0 if no altern.) */ DEF INPUT PARAM p-fontName AS CHAR NO-UNDO. /* e.g. "Arial", "TimesNewRoman",... */ DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. PROCEDURE VpSetTempDir EXTERNAL "viper32.dll" CDECL : DEFINE INPUT PARAMETER p-tmpdir AS CHARACTER NO-UNDO. DEF RETURN PARAM p-err AS SHORT NO-UNDO. END. /* Name : Vpb.i (old viper.p) Purpose: Copyright: Author: Version: changes: * 24.02.03 multitasking intervall removed * 06.10.04 OUTPUT changed to INPUT-OUTPUT due to 10.B 4GL Issue with DLL calls * 25.04.05 jc: vpr_setPageVPos * 03.05.05 jc: vpr_SetDocAttrib * xx.05.05 jc: vpr_FetchCellTextWidth vpr_FetchCellTextHeight * 13.05.05 jc: vpr_SetGraphObj * 26.05.05 jc: vpr_setGroupAttr */ /* The Delimiter. */ DEF VAR l-Delimiter AS CHAR NO-UNDO INIT "". /* A flag indicating if we are in landscape mode */ DEF VAR l-printorientation AS INT NO-UNDO INIT 0. /* Has/is viper succesfully loaded. */ DEF VAR loaded AS INT NO-UNDO. /* Pointer to viper dll. Used to kill dll. */ DEF VAR h-dll AS INT NO-UNDO. /* * variables with values from the viper.ini */ DEF NEW SHARED VAR gvp_gsdir AS CHAR INIT "viper\gs" /*".\gs" */ . DEF NEW SHARED VAR gvp_gsexe AS CHAR INIT "viper\gs\gswin32c.exe" /*".\gs\gswin32c.exe */ . DEF NEW SHARED VAR gvp_gslib AS CHAR INIT "viper\gs" /*".\gs" */ . DEF NEW SHARED VAR gvp_gsfontpath AS CHAR INIT "" /*".\gs" */ . DEF NEW SHARED VAR gvp_webprt AS CHAR INIT "VIPER" /*"PS-Printer" */ . DEF NEW SHARED VAR gvp_WEBPRTACTIVE AS CHAR INIT "OFF" /*"OFF" */ . DEF NEW SHARED VAR gvp_WEBTEMPDIR AS CHAR INIT "vpwebtmp\" /*"vpwebtmp\" */ . DEF NEW SHARED VAR gvp_SRVTEMPDIR AS CHAR INIT "/vpwebtmp/" /*"/vpwebtmp/" */ . /******* Trigger ********/ ON CLOSE OF THIS-PROCEDURE RUN vpr_ViperOff. /******* Main Block **********/ IF THIS-PROCEDURE:PERSISTENT THEN RUN vpr_ViperOn. /******* Viper-Wrapper ******************/ /* Set friendly multitasking, load library and */ PROCEDURE vpr_ViperOn : FILE-INFO:FILE-NAME = "viper\viper32.dll". RUN LoadLibraryA(IF FILE-INFO:FULL-PATHNAME <> ? THEN FILE-INFO:FULL-PATHNAME ELSE "viper\viper32.dll", OUTPUT h-dll). /* RUN LoadLibraryA(IF SEARCH({&VDLL}) <> ? THEN SEARCH({&VDLL}) ELSE {&VDLL}, OUTPUT h-dll). */ /* Startet die Exe-Datei. */ RUN StartViper(OUTPUT loaded). /* Wurde Viper nicht ordentlich geladen, so wird eine 0 zurueckgegeben. */ IF loaded = 0 THEN DO: MESSAGE "Viper could not be started successfully!" VIEW-AS ALERT-BOX. RUN FreeLibrary(h-dll). DELETE PROCEDURE THIS-PROCEDURE. END. RUN vpr_SetDelimiter(CHR(1)). RUN vpr_loadini. RUN vpr_ResetDoc. DEF VAR p-dummy AS INT NO-UNDO. RUN _VpSetGsParams(gvp_GSEXE,gvp_GSDIR,gvp_GSFONTPATH, "-dBATCH -dNOPAUSE -dQUIET", "", "pdfwrite", OUTPUT p-dummy). /* we ignore errors returned by the dll (actually there are none, it always returns 0) */ END. /* of viperon */ /* Leave viper */ PROCEDURE vpr_ViperOff : RUN CloseViper. RUN FreeLibrary(h-dll). DELETE PROCEDURE THIS-PROCEDURE. END. /*********** read Viper INI *******************/ PROCEDURE vpr_loadini: DEF VAR lp-cfgfile AS CHAR NO-UNDO. DEF VAR lp-line AS CHAR NO-UNDO. lp-cfgfile = SEARCH("viper.ini"). IF lp-cfgfile = ? THEN lp-cfgfile = SEARCH("viper/viper.ini"). IF lp-cfgfile <> ? THEN DO: INPUT FROM VALUE(lp-cfgfile). REPEAT: IMPORT UNFORMATTED lp-line. IF TRIM(ENTRY(1,lp-line," ")) BEGINS ";" OR NUM-ENTRIES(lp-line,"=") <> 2 THEN NEXT. CASE TRIM(ENTRY(1,lp-line,"=")): WHEN "VP_GSDIR" THEN gvp_gsdir = TRIM(ENTRY(2,lp-line,"=")). WHEN "VP_GSEXE" THEN gvp_gsexe = REPLACE(TRIM(ENTRY(2,lp-line,"=")),"%VP_GSDIR%", gvp_gsdir). WHEN "VP_GSLIB" THEN gvp_gslib = REPLACE(TRIM(ENTRY(2,lp-line,"=")),"%VP_GSDIR%", gvp_gsdir). WHEN "VP_FONTPATH" THEN gvp_gsfontpath = REPLACE(TRIM(ENTRY(2,lp-line,"=")),"%VP_GSDIR%", gvp_gsdir). WHEN "WEBPRT" THEN gvp_webprt = REPLACE(TRIM(ENTRY(2,lp-line,"=")),'"',''). WHEN "VP_WEBPRTACTIVE" THEN gvp_WEBPRTACTIVE = TRIM(ENTRY(2,lp-line,"=")). WHEN "VP_WEBTEMPDIR " THEN gvp_WEBTEMPDIR = TRIM(ENTRY(2,lp-line,"=")). WHEN "VP_SRVTEMPDIR " THEN gvp_SRVTEMPDIR = TRIM(ENTRY(2,lp-line,"=")). END CASE. END. /* repeat */ IF NOT SESSION:BATCH-MODE THEN DO: INPUT FROM TERMINAL. END. ELSE DO: INPUT CLOSE. END. END. /* IF <> ? */ /* dll does not know about PROPATH */ FILE-INFO:FILE-NAME = gvp_gsdir. IF FILE-INFO:FULL-PATHNAME <> ? THEN gvp_gsdir = FILE-INFO:FULL-PATHNAME. FILE-INFO:FILE-NAME = gvp_gsexe. IF FILE-INFO:FULL-PATHNAME <> ? THEN gvp_gsexe = FILE-INFO:FULL-PATHNAME. FILE-INFO:FILE-NAME = gvp_gslib. IF FILE-INFO:FULL-PATHNAME <> ? THEN gvp_gslib = FILE-INFO:FULL-PATHNAME. FILE-INFO:FILE-NAME = gvp_gsfontpath. IF FILE-INFO:FULL-PATHNAME <> ? THEN gvp_gsfontpath = FILE-INFO:FULL-PATHNAME. FILE-INFO:FILE-NAME = ".". END PROCEDURE. /*************************** * RTF processing commands * ***************************/ /* the declarations needed for embedded formatting at this point ... 06.02.98 jc 24.09.98 jc: rtf agin! */ /* takes string + attributes and returns rtf-formatted string */ PROCEDURE vpr_Asc2RTF : DEF INPUT PARAM p-InString AS CHAR NO-UNDO. DEF INPUT PARAM p-Attribs AS CHAR NO-UNDO. DEF OUTPUT PARAM p-OutString AS CHAR NO-UNDO. DEF VAR lt-opt AS CHAR NO-UNDO INIT "". DEF VAR lt-unopt AS CHAR NO-UNDO INIT "". DEF VAR lt-c AS CHAR NO-UNDO INIT "". DEF VAR lt-i AS INT NO-UNDO INIT -1. /* not tricky, but it works */ IF (LOOKUP("bold",p-Attribs) > 0) THEN DO: lt-opt = lt-opt + "\b ". lt-unopt = lt-unopt + "\b0 ". END. IF (LOOKUP("italic",p-Attribs) > 0) THEN DO: lt-opt = lt-opt + "\i ". lt-unopt = lt-unopt + "\i0 ". END. IF (LOOKUP("underline",p-Attribs) > 0) THEN DO: lt-opt = lt-opt + "\ul ". lt-unopt = lt-unopt + "\ul0 ". END. IF (LOOKUP("strike",p-Attribs) > 0) THEN DO: lt-opt = lt-opt + "\s ". lt-unopt = lt-unopt + "\s0 ". END. /* keep this order, please */ /* not needed/used currently... 6.2.98 (jc) */ p-InString = REPLACE(p-InString,"\","\\"). p-InString = REPLACE(p-InString,CHR(9),"\tab "). p-InString = REPLACE(p-InString,CHR(13) + CHR(10),"\par "). p-InString = REPLACE(p-InString,CHR(13),"\par "). p-InString = REPLACE(p-InString,CHR(10),"\par "). p-InString = REPLACE(p-InString,"~{","\~{"). p-InString = REPLACE(p-InString,"~}","\~}"). p-OutString = lt-opt + p-InString + lt-unopt. /* + {&RPlain}. */ /* options + text + 'reset' */ END. /********************************************* * Creation and deletion of cells and groups * ********************************************/ /* create a cell in a group */ PROCEDURE vpr_DefCell: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetCell (CAPS(p-cell), CAPS(p-group), "Create":U, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefCell: Error". END. /* Delete a cell */ PROCEDURE vpr_DelCell: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetCell (CAPS(p-cell), CAPS(p-group), "Destroy", OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DelCell: Error". END. /************************************* * Setting cell and group attributes * *************************************/ /* Set cell attributes */ PROCEDURE vpr_SetCellAttrib: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attribs AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO INIT 0. DEF VAR c_entry AS CHAR NO-UNDO. DEF VAR ii AS INT NO-UNDO. DEF VAR ij AS INT NO-UNDO. ij = NUM-ENTRIES(p-attribs). DO ii = 1 TO ij: c_entry = ENTRY(ii,p-attribs). IF TRIM(ENTRY(1,c_entry,"=")) = "RTF" THEN DO: IF TRIM(ENTRY(2,c_entry,"=")) = "ON" THEN RUN VpSetCellRTF (CAPS(p-cell), CAPS(p-group), 1, OUTPUT p-err). ELSE RUN VpSetCellRTF (CAPS(p-cell), CAPS(p-group), 0, OUTPUT p-err). END. END. IF p-err <> 0 THEN RETURN ERROR "SetCellAttrib: Error". END. /* * SetCellLineSpacing - Set the space between lines */ PROCEDURE vpr_SetCellLineSpacing: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-space AS DEC NO-UNDO. DEF VAR p-err AS INT NO-UNDO INIT 0. RUN VpSetCellLineSpacing (CAPS(p-cell), CAPS(p-group), p-space, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellLineSpacing: Error". END. /* set RTF */ PROCEDURE vpr_SetCellRTF: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attrib AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO INIT 0. p-attrib=TRIM(CAPS(p-attrib)). IF p-attrib = "ON" OR p-attrib = "TRUE" OR p-attrib = "YES" OR p-attrib = "RTF" THEN DO: RUN VpSetCellRTF (CAPS(p-cell), CAPS(p-group), 1, OUTPUT p-err). END. ELSE DO: RUN VpSetCellRTF (CAPS(p-cell), CAPS(p-group), 0, OUTPUT p-err). END. IF p-err <> 0 THEN RETURN ERROR "SetCellRTF: Error". END. /* Set the text value of a cell */ PROCEDURE vpr_SetCellText: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. /* No-formatted text (s.t.c.) */ DEF VAR p-err AS INT NO-UNDO. RUN VpText (CAPS(p-cell), CAPS(p-group), p-text, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellText: Error". END. /* Set the text value of a cell */ PROCEDURE vpr_SetCellLongText: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS LONGCHAR NO-UNDO. /* No-formatted text (s.t.c.) */ DEF VAR p-err AS INT NO-UNDO. RUN VpText (CAPS(p-cell), CAPS(p-group), p-text, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellLongText: Error". END. /* SetDelimiter: only here because of its close connexion to SetGroupText */ PROCEDURE vpr_SetDelimiter: DEF INPUT PARAM p-del AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetDelimiter IN THIS-PROCEDURE (INPUT p-del, OUTPUT p-err) NO-ERROR. IF p-err <> 0 THEN RETURN ERROR "SetDelimiter: Error". /* xxx */ l-Delimiter = p-Del. END. /* of setdelimiter */ /* Set the text value of a cell */ PROCEDURE vpr_SetGroupText: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF INPUT PARAM p-texts AS CHAR NO-UNDO. /* No-formatted text (s.t.c.) */ DEF VAR p-err AS INT NO-UNDO. RUN VpSetGroupText (CAPS(p-group), CAPS(p-cells), p-texts, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetGroupText: Error". END. /* Position a cell (set size/place) (per 0.1 mm) */ PROCEDURE vpr_SetCellPos: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetRect(CAPS(p-cell),CAPS(p-group),p-x,p-y,p-width,p-height, OUTPUT p-err). IF p-err <>0 THEN DO: /* DISPLAY "FEHLER: ". DISPLAY STRING(p-err). */ RETURN ERROR "SetCellPos: Error". END. END. /* Set a cells height (per 0.1 mm) */ PROCEDURE vpr_SetCellHeight: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetCellHeight(CAPS(p-cell),CAPS(p-group),p-height, OUTPUT p-err). IF p-err <>0 THEN DO: RETURN ERROR "SetCellHeight: Error". END. END. /* set font in cell ke, 18.04.97; No more font family. Set to 0. */ PROCEDURE vpr_SetCellFont_OLD: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. /* use a list of italic,underline,strikeout,bold */ DEF INPUT PARAM p-format AS CHAR NO-UNDO. /* e.g. "Arial", "TimesNewRoman",... */ DEF INPUT PARAM p-fontName AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Format AS INT NO-UNDO. RUN vpr_CalcFormat (p-Format, OUTPUT l-Format). RUN VpSetFont(CAPS(p-cell), CAPS(p-group), p-height, p-width, l-format, 0, p-fontName, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellFont: Error". END. /* set font in cell * new version using decimals for height and width * Aug 15, 2011 jc */ PROCEDURE vpr_SetCellFont: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-height AS DEC NO-UNDO. DEF INPUT PARAM p-width AS DEC NO-UNDO. /* use a list of italic,underline,strikeout,bold */ DEF INPUT PARAM p-format AS CHAR NO-UNDO. /* e.g. "Arial", "TimesNewRoman",... */ DEF INPUT PARAM p-fontName AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Format AS INT NO-UNDO. RUN vpr_CalcFormat (p-Format, OUTPUT l-Format). RUN VpSetCellFont(CAPS(p-cell), CAPS(p-group), p-height, p-width, l-format, 0, p-fontName, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellFont: Error". END. /* * set the codepage for the cell * jc 12.11.04 */ PROCEDURE vpr_SetCellCodePage: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-CP AS CHAR NO-UNDO. /* No-formatted text (s.t.c.) */ DEF VAR p-res AS INT NO-UNDO. RUN VpSetCellCodePage(CAPS(p-cell), CAPS(p-group), CAPS(p-CP), OUTPUT p-res). END. /* Set the resize-flag of cell (increasing cell = yes) Parameter p-dynamic set to logical parameter. */ PROCEDURE vpr_SetCellAutoResize: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* 0 = static / 1 = dynamic cell */ DEF INPUT PARAM p-AutoRes AS CHAR NO-UNDO. DEFINE VARIABLE p-err AS INT NO-UNDO. DEFINE VARIABLE lp-autores AS LOG NO-UNDO. CASE TRIM(p-AutoRes): WHEN "TRUE" THEN DO: lp-AutoRes = TRUE. END. WHEN "YES" THEN DO: lp-AutoRes = TRUE. END. WHEN "ON" THEN DO: lp-AutoRes = TRUE. END. WHEN "1" THEN DO: lp-AutoRes = TRUE. END. WHEN "resize" THEN DO: lp-AutoRes = TRUE. END. OTHERWISE DO: lp-AutoRes = FALSE. END. END. RUN VpSetResize(CAPS(p-cell), CAPS(p-group), IF lp-AutoRes THEN 1 ELSE 0, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellAutoResize: Error". END. /* Set the wrap behavior of a cell. */ PROCEDURE vpr_SetCellWrap: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-Wrap AS CHAR NO-UNDO. /* wrap on/off, off is default */ DEFINE VARIABLE p-err AS INT NO-UNDO. DEFINE VARIABLE lp-wrap AS LOG NO-UNDO. lp-wrap = FALSE. CASE TRIM(p-wrap): WHEN "TRUE" THEN DO: lp-wrap = TRUE. END. WHEN "WRAP" THEN DO: lp-wrap = TRUE. END. WHEN "ON" THEN DO: lp-wrap = TRUE. END. END. RUN VpSetCellWrap (CAPS(p-cell), CAPS(p-group), IF lp-Wrap THEN 1 ELSE 0, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellWrap: Error". END. /* Set the Skip before and after a group. The skip area is an invisible place to get better looking printouts. */ PROCEDURE vpr_SetGroupSkip: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-Point AS CHAR NO-UNDO. DEF INPUT PARAM p-pre AS INT NO-UNDO. DEF INPUT PARAM p-post AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetGroupSkip ( CAPS(p-group), p-pre, p-post, IF CAN-DO("Points,Point,Pt", p-Point) THEN 1 ELSE 0 , OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetGroupSkip: Error". END. /* * helper to change the "align" value from strings to the number encoding used internally * - SetCellAlign * * jc, 19.04.02 */ PROCEDURE vpr_my_changealign: DEFINE INPUT PARAMETER p-char AS CHAR NO-UNDO. DEFINE OUTPUT PARAMETER p-style AS INT NO-UNDO. /* * support old numbers... */ p-style = INTEGER(p-char) NO-ERROR. IF NOT ERROR-STATUS:ERROR THEN RETURN. CASE TRIM(p-char): WHEN "left" THEN DO: p-style = 1. END. WHEN "right" THEN DO: p-style = 2. END. WHEN "center" THEN DO: p-style = 3. END. WHEN "block" THEN DO: p-style = 4. END. WHEN "justify" THEN DO: p-style = 4. END. OTHERWISE DO: p-style = 0. END. END. END. /* Justifies in cell; s.docu for possible values */ PROCEDURE vpr_SetCellAlign: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. /* 0, 1 = linksbuendig, 2 = rechtsbuendig, 3 = zentriert, 4 = blocksatz (noch nicht implementiert) */ DEF INPUT PARAM p-type AS CHAR NO-UNDO. DEFINE VARIABLE p-err AS INT NO-UNDO. DEFINE VARIABLE lp-type AS INT NO-UNDO. RUN vpr_my_changealign(p-type, OUTPUT lp-type). RUN VpSetJustify(CAPS(p-cell), CAPS(p-group), lp-type, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellAlign: Error". END. /* SetCellColor - sets the Colors and BkMode for Cells */ PROCEDURE vpr_SetCellColor: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-textc AS CHAR NO-UNDO. DEF INPUT PARAM p-backc AS CHAR NO-UNDO. DEF VAR i-textc AS INT NO-UNDO. DEF VAR i-backc AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. IF p-backC = "" OR p-BackC = ? THEN DO: RUN vpr_CalcCol (p-textc, OUTPUT i-textc). RUN VpSetCellColor (CAPS(p-cell), CAPS(p-group), i-textc, 0, 0, OUTPUT p-err). END. ELSE DO: RUN vpr_CalcCol (p-textc, OUTPUT i-textc). RUN vpr_CalcCol (p-backc, OUTPUT i-backc). RUN VpSetCellColor (CAPS(p-cell), CAPS(p-group), i-textc, i-backc, 1, OUTPUT p-err). END. /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "SetCellColor: Error". END. /* 19.1.98 */ /* SetGroupVPos - set the groups vertical position 19.01.98 jpc */ PROCEDURE vpr_SetGroupVPos: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-VPos AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetGroupVPos(INPUT CAPS(p-group), INPUT p-VPos, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "SetGroupVPos: Error". END. /* 24.09.98 */ /* SetGroupCellPositioning - sets how the cells are positioned on flushgroup and setGroupVPos 24.09.98 jpc */ PROCEDURE vpr_SetGroupCellPositioning: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-Style AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetGroupCellPositioning(INPUT CAPS(p-group), INPUT p-Style, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "SetGroupCellPositioning: Error". END. /* SetCellSplit - sets if the cell should be able to have multiple "instances", i.e. if a part of the cells text does not fit into it, keep some or all of the text for the next "incarnation" 13.11.98 jpc */ PROCEDURE vpr_SetCellSplit: DEF INPUT PARAM p-Group AS CHAR NO-UNDO. DEF INPUT PARAM p-Cell AS CHAR NO-UNDO. DEF INPUT PARAM p-split AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR lp-split AS INT NO-UNDO. lp-split = 0. p-split = CAPS(TRIM(p-split)). IF p-split = "COPY" THEN lp-split=2. IF p-split = "SPLIT" THEN lp-split=1. IF p-split = "ON" THEN lp-split=1. RUN VpSetCellSplit(CAPS(p-group), CAPS(p-cell), lp-split, OUTPUT p-err). /* Error-Tracking */ IF p-err <> 0 THEN RETURN ERROR "SetCellSplit: Error". END. /**************************** * BUFFER STUFFA * * 10.12.98 jc * ****************************/ /* SetCellText: Set the buffer value of a cell This overwrites the previous buffer contents 10.12.98 jc */ PROCEDURE vpr_SetCellBuffer: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetCellBuffer (CAPS(p-cell), CAPS(p-group), p-text, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellBuffer: Error". END. /* AddToCellText: Append text to the buffer 10.12.98 jc */ PROCEDURE vpr_AddToCellBuffer: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-text AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpAddToCellBuffer (CAPS(p-cell), CAPS(p-group), p-text, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "AddToCellBuffer: Error". END. /* DeleteCellText: Clear a cells buffer 10.12.98 jc */ PROCEDURE vpr_DeleteCellBuffer: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpDeleteCellBuffer (CAPS(p-cell), CAPS(p-group), OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DeleteCellBuffer: Error". END. /* SubmitCellText: Append text to the buffer 10.12.98 jc */ PROCEDURE vpr_SubmitCellBuffer: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSubmitCellBuffer (CAPS(p-cell), CAPS(p-group), OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SubmitCellBuffer: Error". END. /**************************************** * Fetch cell, group, and page attributes * ****************************************/ /* * FetchCellWidth - retrieve the width of a cell */ PROCEDURE vpr_FetchCellWidth: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-width AS INT NO-UNDO. RUN VpGetCellWidth(CAPS(p-cell), CAPS(p-group), OUTPUT p-width). IF p-width = -1 THEN RETURN ERROR "FetchCellWidth: Error". END. /* gives height of cell */ PROCEDURE vpr_FetchCellHeight: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-height AS INT NO-UNDO. /* DEF VAR p-err AS INT NO-UNDO. */ RUN VpCellHeight(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). IF p-height = -1 THEN RETURN ERROR "FetchCellHeight: Error". END. /* Returns height of group. The height of the group is the height of the heighest cell. */ PROCEDURE vpr_FetchGroupHeight : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-height AS INT NO-UNDO. /* DEF VAR p-err AS INT NO-UNDO. */ RUN VpGroupHeight(CAPS(p-group), OUTPUT p-height). IF p-height = -1 THEN RETURN ERROR "FetchGroupHeight: Error". END. /* Returns free vertical space on page (with flushed cells) */ PROCEDURE vpr_FetchPageVSpace: DEF OUTPUT PARAM p-space AS INT NO-UNDO. /* DEF VAR p-err AS INT NO-UNDO. */ RUN VpGetFree(OUTPUT p-space). /* Error-Tracking. */ IF p-Space = -1 THEN RETURN ERROR "VpFetchFree: Error". END. /* Returns vertical position of cursor */ PROCEDURE vpr_FetchPageVPos: DEF OUTPUT PARAM p-pos AS INT NO-UNDO. /* DEF VAR p-err AS INT NO-UNDO. */ RUN VpGetPos(OUTPUT p-pos). END. /* Returns number of pages (=actual page) */ PROCEDURE vpr_FetchPageNo: DEF OUTPUT PARAM p-page AS INT NO-UNDO. /* DEF VAR p-err AS INT NO-UNDO. */ RUN VpGetPages(OUTPUT p-page). IF p-page = -1 THEN RETURN ERROR "FetchPageNo: Error". END. /* 19.1.98 */ /* FetchCellVPos - Fetch the vertical position of a cell 19.1.98 jpc */ PROCEDURE vpr_FetchCellVPos: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF OUTPUT PARAM p-VPos AS INT NO-UNDO. RUN VpGetCellVPos(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-VPos). END. /* FetchCellHPos - Fetch the horizontal position of a cell 19.1.98 jpc */ PROCEDURE vpr_FetchCellHPos: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF OUTPUT PARAM p-HPos AS INT NO-UNDO. RUN VpGetCellHPos(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-HPos). END. /* FetchGroupVPos - Fetch the vertical position of a group 19.1.98 jpc */ PROCEDURE vpr_FetchGroupVPos: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-VPos AS INT NO-UNDO. RUN VpGetGroupVPos(INPUT CAPS(p-group), OUTPUT p-VPos). END. /* 23.11.98 */ /* FetchCellLineCount - return the number of lines in a cell 23.11.98 jpc */ PROCEDURE vpr_FetchCellLineCount: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-cells AS CHAR NO-UNDO. DEF OUTPUT PARAM p-LineCount AS INT NO-UNDO. RUN VpGetCellLineCount(INPUT CAPS(p-group), INPUT CAPS(p-cells), OUTPUT p-LineCount). END. /**************************** * FlushGroup, NewPage, etc * ****************************/ /* prints all cells of given group and increases the line pointer of this group. */ PROCEDURE vpr_FlushGroup : DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpFlushGroup(CAPS(p-group), OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "FlushGroup: Error". END. /* creates new page and resets cell-coordinates */ PROCEDURE vpr_NewPage: DEF VAR p-err AS INT NO-UNDO. RUN VpNewPage(OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "NewPage: Error". END. /* sets properties like PageOrientation and PaperTray for the current page 27.08.1999 jc */ PROCEDURE vpr_SetCurrentPageProperties: DEF INPUT PARAM p-prop AS CHAR NO-UNDO. DEF INPUT PARAM p-value AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. p-value = IF p-value = "Portrait" THEN "1" ELSE IF p-value = "Landscape" THEN "2" ELSE p-value. RUN VpSetCurrentPageProperties(CAPS(p-prop), p-value, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCurrentPageProperties: Error". END. /* * vpr_SetPageVPos: Set the current pos on the current page * 25.04.05 jc */ PROCEDURE vpr_SetPageVPos: DEF INPUT PARAM p-pos AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetPageVPos(p-pos, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetPageVPos: Error". END. /* * SetPaperSize: Set the current paper size * * 03.07.2001 jc */ PROCEDURE vpr_SetPaperSize: DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetPaperSize(p-width, p-height, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetPaperSize: Error". END. /* Start printing from page-no to page-no. To print all supply 0, 0 */ PROCEDURE vpr_PrintDoc: DEF INPUT PARAM p-from AS INT NO-UNDO. DEF INPUT PARAM p-to AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpPrint(p-from, p-to, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "PrintDoc: Error". END. /* * PrintPDF: * "Printing" to a PDF file, analogous to PrintDoc * except for the additional parameter p-FNAM, that provides * the filename for the PDF file. * If p-FNAM is left blank viper will create a temporary file * and return its name in FNAM */ PROCEDURE vpr_PrintPDF: DEF INPUT PARAM p-from AS INT NO-UNDO. DEF INPUT PARAM p-to AS INT NO-UNDO. DEF INPUT-OUTPUT PARAM p-fnam AS CHAR NO-UNDO. DEF VAR fOut AS CHAR NO-UNDO. DEF VAR fPDF AS CHAR NO-UNDO. DEF VAR Com AS CHAR NO-UNDO. DEF VAR lp-optional-ps AS CHAR NO-UNDO INIT "". /* optional ps file, used for landscape */ DEF VAR lp-papersize AS CHAR NO-UNDO INIT "a4". DEF VAR p-err AS INT NO-UNDO. fOut=FILL(" ",255). /* ensure fOut has enuff room */ /* bug in 10.0B */ RUN VpWebPrintDoc(p-from, p-to, gvp_webprt, INPUT-OUTPUT fOut, OUTPUT p-err). fOut = TRIM(fOut). fPDF = SUBSTR(fOut, 1, R-INDEX(fOut, ".")) + "pdf". /* win8 / gs9 fix */ /** IF l-printorientation = 2 THEN DO: /* Landscape */ /* lp-optional-ps = "lscap.ps". */ lp-papersize = lp-papersize + "q". RUN VpSetLandscapePS(fOut,1, OUTPUT p-err). /* setlandscape: forcerotate!! */ END. RUN VpPS2PDF(gvp_GSEXE, gvp_GSDIR, gvp_GSFONTPATH, "-dBATCH -dNOPAUSE -dQUIET -r300x300 -sPAPERSIZE=" + lp-papersize, lp-optional-ps, /* "-r300x300 -sPAPERSIZE=" + lp-papersize, lp-optional-ps,*/ "pdfwrite",fOut,fPDF, OUTPUT p-err). **/ IF l-printorientation = 2 THEN DO: /* Landscape */ lp-papersize = "-dDEVICEWIDTHPOINTS=842 -dDEVICEHEIGHTPOINTS=595 -dNORANGEPAGESIZE". END. ELSE DO: lp-papersize = "-sPAPERSIZE=a4". END. RUN VpPS2PDF(gvp_GSEXE, gvp_GSDIR, gvp_GSFONTPATH, "-dBATCH -dNOPAUSE -dQUIET -r300x300 " + lp-papersize, lp-optional-ps, "pdfwrite",fOut,fPDF, OUTPUT p-err). /* win8 / gs9 fix */ IF p-err = 0 THEN DO: /* only delete the ps-file if no error has occured. */ OS-DELETE VALUE(fOUT). END. IF p-fnam = "" THEN DO: p-fnam = fPDF. END. ELSE DO: FILE-INFO:FILE-NAME = p-fnam. IF FILE-INFO:FULL-PATHNAME <> ? THEN DO: OS-DELETE VALUE(FILE-INFO:FULL-PATHNAME). END. OS-COPY VALUE(fPDF) VALUE(p-fnam). OS-DELETE VALUE(fPDF). END. IF p-err <> 0 THEN RETURN ERROR "PrintPDF: Error". END. PROCEDURE vpr_WebPrintDoc: DEF INPUT PARAM p-from AS INT NO-UNDO. DEF INPUT PARAM p-to AS INT NO-UNDO. DEF INPUT PARAM p-method AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR fOut AS CHAR NO-UNDO. DEF VAR fPDF AS CHAR NO-UNDO. DEF VAR Com AS CHAR NO-UNDO. DEF VAR fPDF_base AS CHAR NO-UNDO. DEF VAR lp-papersize AS CHAR NO-UNDO INIT "a4". DEF VAR lp-tmp AS CHAR NO-UNDO. DEF VAR lp-crlf AS CHAR NO-UNDO. lp-crlf = CHR(13) + CHR(10). fOut=FILL(" ",255). /* ensure fOut has 'nuff room */ RUN vpr_PrintOptions("ShowPrintStatus","Off","","",""). RUN VpWebPrintDoc(p-from, p-to, gvp_webprt, OUTPUT fOut, OUTPUT p-err). fOut = TRIM(fOut). fPDF = SUBSTR(fOut, 1, R-INDEX(fOut, ".")) + "pdf". /** Com = "{&WEBPS2PDF} " + SUBSTR(fOut, 1, R-INDEX(fOut, ".") - 1) + ' "{&VP_GSDIR}"'. OS-COMMAND SILENT VALUE(Com). */ IF l-printorientation = 2 THEN DO: /* Landscape */ lp-papersize = lp-papersize + "q". RUN VpSetLandscapePS(fOut,1, OUTPUT p-err). /* setlandscape: forcerotate!! */ END. RUN VpPS2PDF(gvp_GSEXE, gvp_GSDIR, gvp_GSFONTPATH, "-dBATCH -dNOPAUSE -dQUIET -r300x300 -sPAPERSIZE=" + lp-papersize, "", /* "-r300x300 -sPAPERSIZE=" + lp-papersize, "",*/ "pdfwrite",fOut,fPDF, OUTPUT p-err). IF p-err = 0 THEN DO: /* only delete the ps-file if no error has occured. */ OS-DELETE VALUE(fOUT). END. MESSAGE "WebPrinting is not enabled" VIEW-AS ALERT-BOX. IF p-err <> 0 THEN RETURN ERROR "WebPrintDoc: Error". END. /****************** * Graphics stuff * ******************/ /* * helper to change the linestyles from strings to the number encoding used internally * * jc, 19.04.02 */ PROCEDURE vpr_my_changestyle: DEFINE INPUT PARAMETER p-char AS CHAR NO-UNDO. DEFINE OUTPUT PARAMETER p-style AS INT NO-UNDO. /* * support old numbers... */ p-style = INTEGER(p-char) NO-ERROR. IF NOT ERROR-STATUS:ERROR THEN RETURN. CASE TRIM(p-char): WHEN "Solid" THEN DO: p-style = 0. END. WHEN "Dash" THEN DO: p-style = 1. END. WHEN "Dot" THEN DO: p-style = 2. END. WHEN "DashDot" THEN DO: p-style = 3. END. WHEN "DashDotDot" THEN DO: p-style = 4. END. OTHERWISE DO: p-style = 0. END. END. END. /* * helper to change the "justify" value from strings to the number encoding used internally * * jc, 19.04.02 */ PROCEDURE vpr_my_changejustify: DEFINE INPUT PARAMETER p-char AS CHAR NO-UNDO. DEFINE OUTPUT PARAMETER p-style AS INT NO-UNDO. /* * support old numbers... */ p-style = INTEGER(p-char) NO-ERROR. IF NOT ERROR-STATUS:ERROR THEN RETURN. CASE TRIM(p-char): WHEN "fill" THEN DO: p-style = -1. END. WHEN "left" THEN DO: p-style = 1. END. WHEN "right" THEN DO: p-style = 2. END. WHEN "center" THEN DO: p-style = 3. END. WHEN "centered" THEN DO: p-style = 3. END. OTHERWISE DO: p-style = 0. END. END. END. /* * helper to change the "fill" value (for rectangles) from strings to the number encoding used internally * * jc, 19.04.02 */ PROCEDURE vpr_my_changefilled: DEFINE INPUT PARAMETER p-char AS CHAR NO-UNDO. DEFINE OUTPUT PARAMETER p-style AS INT NO-UNDO. /* * support old numbers... */ p-style = INTEGER(p-char) NO-ERROR. IF NOT ERROR-STATUS:ERROR THEN RETURN. CASE TRIM(p-char): WHEN "fill" THEN DO: p-style = 1. END. WHEN "filled" THEN DO: p-style = 1. END. WHEN "true" THEN DO: p-style = 1. END. WHEN "yes" THEN DO: p-style = 1. END. WHEN "on" THEN DO: p-style = 1. END. OTHERWISE DO: p-style = 0. END. END. END. /* draw line * jc - yet another very old one * ke, changed color to char. * jc, 19.04.02 - changed p-style parameter to char, supporting sensible names * for the line styles */ PROCEDURE vpr_DefFreeLine: DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF INPUT PARAM p-style AS CHAR NO-UNDO. DEF INPUT PARAM p-bwidth AS INT NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEF VAR lp-style AS INT NO-UNDO. RUN vpr_my_changestyle (p-style, OUTPUT lp-style). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpFreeLine(p-x, p-y, p-width, p-height, lp-style, p-bwidth, l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefFreeLine: Error". END. /* draw rectangle */ PROCEDURE vpr_DefRect: DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF INPUT PARAM p-filled AS CHAR NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEFINE VARIABLE lp-filled AS INT NO-UNDO. RUN vpr_my_changefilled(p-filled, OUTPUT lp-filled). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpRectangle(p-x,p-y,p-width,p-height,lp-filled,l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefRect: Error". END. /* draw rounded rectangle */ PROCEDURE vpr_DefRndRect : DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF INPUT PARAM p-filled AS CHAR NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEFINE VARIABLE lp-filled AS INT NO-UNDO. RUN vpr_my_changefilled(p-filled, OUTPUT lp-filled). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpRoundRect(p-x,p-y,p-width,p-height,lp-filled,l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefRndRect: Error". END. /* horizontal line */ PROCEDURE vpr_DefHLine : DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-len AS INT NO-UNDO. DEF INPUT PARAM p-style AS CHAR NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEF VAR lp-style AS INT NO-UNDO. RUN vpr_my_changestyle (p-style, OUTPUT lp-style). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpHLine(p-x,p-y,p-len,lp-style,p-width,l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefHLine: Error". END. /* vertical line */ PROCEDURE vpr_DefVLine : DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-len AS INT NO-UNDO. DEF INPUT PARAM p-style AS CHAR NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEF VAR lp-style AS INT NO-UNDO. RUN vpr_my_changestyle (p-style, OUTPUT lp-style). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpVLine(p-x,p-y,p-len,lp-style,p-width,l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefVline: Error". END. /* sets horizontal separator (line) at current cursor-pos. */ PROCEDURE vpr_DefHSep: DEF INPUT PARAM p-len AS INT NO-UNDO. DEF INPUT PARAM p-justify AS CHAR NO-UNDO. DEF INPUT PARAM p-style AS CHAR NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-col AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR l-Col AS INT NO-UNDO. DEF VAR lp-style AS INT NO-UNDO. RUN vpr_my_changestyle (p-style, OUTPUT lp-style). DEF VAR lp-justify AS INT NO-UNDO. RUN vpr_my_changejustify (p-justify, OUTPUT lp-justify). RUN vpr_CalcCol (p-Col, OUTPUT l-Col). RUN VpHSep(p-len,lp-justify,lp-style,p-width,l-col, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefHSep: Error". END. /**************************** * error reporting * ****************************/ /* read-error-report */ PROCEDURE vpr_VReadErrors: /* last error-no. */ DEF INPUT-OUTPUT PARAM p-lasterr AS INT NO-UNDO. /* number of errors occured */ DEF OUTPUT PARAM p-err AS INT NO-UNDO. RUN ReadErrors(INPUT-OUTPUT p-lasterr, OUTPUT p-err). /* IF p-err = -1 THEN RETURN ERROR ": Error".*/ END. /******************************* * nifty little picture things * *******************************/ /* * vpr_DefBMP: * Define a Bitmap to be shown by Viper * jc - one of the earliest commands we had... * jc - 19.04.02/Viper3.0: removed the two logical paramter, added * one character instead. Use sensible strings now [No]Resize/[No]KeepRatio */ PROCEDURE vpr_DefBmp: DEF INPUT PARAM p-Name AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF INPUT PARAM p-mode AS CHAR NO-UNDO. DEFINE VARIABLE lp-adjust AS LOG NO-UNDO. DEFINE VARIABLE lp-ratio AS LOG NO-UNDO. DEFINE VARIABLE lp-ii AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR lp-savename AS CHAR NO-UNDO. lp-adjust = FALSE. lp-ratio = FALSE. DO lp-ii = 1 TO NUM-ENTRIES(p-mode): CASE TRIM(ENTRY(lp-ii, p-mode)): WHEN "KeepRatio" THEN DO: lp-ratio = TRUE. END. WHEN "NoKeepRatio" THEN DO: lp-ratio = FALSE. END. WHEN "Keep" THEN DO: lp-ratio = TRUE. END. WHEN "NoKeep" THEN DO: lp-ratio = FALSE. END. WHEN "Ratio" THEN DO: lp-ratio = TRUE. END. WHEN "NoRatio" THEN DO: lp-ratio = FALSE. END. WHEN "Resize" THEN DO: lp-adjust = TRUE. END. WHEN "NoResize" THEN DO: lp-adjust = FALSE. END. END. END. /* make sure we find the pix */ /* save current value of FUEL-INFO */ lp-savename = FILE-INFO:FULL-PATHNAME. /* get full-pathname to the pic. */ FILE-INFO:FILE-NAME = p-name. p-name = FILE-INFO:FULL-PATHNAME. /* restore FILE-INFO */ FILE-INFO:FILE-NAME = lp-savename. IF p-Name = ? THEN DO: RETURN ERROR "DefBmp: Error - file not found". END. RUN VpBitMap (p-name, p-x, p-y, p-width, p-height, IF lp-adjust THEN 1 ELSE 0, IF lp-ratio THEN 1 ELSE 0, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "DefBmp: Error". END. /* SaveClipboardToFile - saves the clipboard contents Type: defines the datatype to be saved. so far only bitmap (BMP) and Device Independent Bitmap (DIB) is supported FileIn: Filename to save the data to. if no FileIn is given (i.e. an empty string) a temporary file with a unique filename is chosen. FileOut: returns the filename. empty if the procedure fails. 17.07.98 jc */ PROCEDURE vpr_SaveClipboardToFile: DEF INPUT PARAM Type AS CHAR NO-UNDO. DEF INPUT PARAM FileIn AS CHAR NO-UNDO. DEF OUTPUT PARAM FileOut AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR iType AS INT NO-UNDO. iType=0. CASE Type: WHEN "BITMAP" THEN iType=2. WHEN "BMP" THEN iType=2. WHEN "DIB" THEN iType=2. END CASE. FileOut=FILL(" ",255). /* ensure FileOut has 'nuff room */ /* bug in 10.0B */ RUN VpSaveClipboardToFile(iType,FileIn,INPUT-OUTPUT FileOut, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SaveClipboardToFile: Error". END. /* SaveWindowToFile - saves the given window as DIB HWND: Windowhandle of the window that should be saved. AreaType: Save all of HWND or only clientarea? FileIn: Filename to save the data to. if no FileIn is given (i.e. an empty string) a temporary file with a unique filename is chosen. FileOut: returns the filename. empty if the procedure fails. 17.07.98 jc */ PROCEDURE vpr_SaveWindowToFile: DEF INPUT PARAM HWND AS INT NO-UNDO. DEF INPUT PARAM AreaType AS CHAR NO-UNDO. DEF INPUT PARAM FileIn AS CHAR NO-UNDO. DEF OUTPUT PARAM FileOut AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. DEF VAR iType AS INT NO-UNDO. iType=2. CASE AreaType: WHEN "ALL" THEN iType=1. WHEN "WINDOW" THEN iType=1. WHEN "CLIENT" THEN iType=2. END CASE. FileOut=FILL(" ",255). /* ensure FileOut has 'nuff room */ /* bug in 10.0.b */ RUN VpSaveWindowToFile(HWND,iType,FileIn,INPUT-OUTPUT FileOut, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SaveWindowToFile: Error". END. /************************* * window control stuff * *************************/ /* Show the preview window */ PROCEDURE vpr_ShowPreview: /* DEF OUTPUT PARAM p-err AS SHORT NO-UNDO. */ DEF VAR p-err AS INT NO-UNDO. RUN VpShowPreview(OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "ShowPreview: Error". END. /* Hide the preview window */ PROCEDURE vpr_HidePreview: DEF VAR p-err AS INT NO-UNDO. RUN VpHidePreview(OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "HidePreview: Error". END. /* * Get the current preview state (hidden/visible) * * 17.03.03 jc */ PROCEDURE vpr_FetchPreviewStatus: DEF INPUT PARAM p-wait AS INT NO-UNDO. DEF OUTPUT PARAM p-status AS INT NO-UNDO. DEF VAR p-prevstat AS CHAR NO-UNDO. RUN VpGetPreviewStatus(INPUT p-wait, OUTPUT p-status). IF p-status=1 THEN DO: p-prevstat = "visible". END. ELSE DO: p-prevstat = "hidden". END. END. /* Set the window position and size */ PROCEDURE vpr_SetWindowPos: DEF INPUT PARAM p-left AS INT NO-UNDO. DEF INPUT PARAM p-top AS INT NO-UNDO. DEF INPUT PARAM p-width AS INT NO-UNDO. DEF INPUT PARAM p-height AS INT NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetWindowPos(p-left, p-top, p-width, p-height, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "SetWindowPos: Error". END. /* * show a persistent preview */ PROCEDURE vpr_ShowDoc: DEF VAR p-err AS INT NO-UNDO. DEF VAR lp-fnam AS CHAR NO-UNDO. RUN VpShowDoc(OUTPUT p-err). IF p-err = 1 THEN DO: lp-fnam = SEARCH("VprRead.exe"). IF lp-fnam = ? THEN DO: RETURN ERROR "vpr_showDoc: no way to find VprRead.exe". END. ELSE DO: OS-COMMAND SILENT NO-CONSOLE VALUE(lp-fnam + "/install"). RUN VpShowDoc(OUTPUT p-err). END. END. /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "vpr_ShowDoc: Error". END. /************************* * Printer control stuff * *************************/ /* select printer */ PROCEDURE vpr_SelectPrinter: DEF INPUT PARAM p-name AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSelectPrinter(INPUT p-name, OUTPUT p-err). /* Error-Tracking. */ IF p-err = 2 THEN RETURN "2". IF p-err <> 0 THEN RETURN ERROR "SelectPrinter: Error". END. /* PrintOptions: You can set different options in VIPER. They are ugly code, most with integer. */ PROCEDURE vpr_PrintOptions: /* Name of option you want to set. officially known: orientation, Previewmode. */ DEF INPUT PARAM p-Mode AS CHAR NO-UNDO. /* Option 1 to 4 are char options for the user. */ DEF INPUT PARAM p-Opt1 AS CHAR NO-UNDO. DEF INPUT PARAM p-Opt2 AS CHAR NO-UNDO. DEF INPUT PARAM p-Opt3 AS CHAR NO-UNDO. DEF INPUT PARAM p-Opt4 AS CHAR NO-UNDO. DEF VAR lp-Int1 AS INT NO-UNDO. DEF VAR lp-Int2 AS INT NO-UNDO. DEF VAR lp-Int3 AS INT NO-UNDO. DEF VAR lp-Char1 AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. /* Switch char options to numeric values. */ CASE p-Mode: WHEN "Orientation":U THEN DO: /* Option1 is orientation mode. Opt2-Opt4 are meaningless. */ lp-Int1 = IF p-Opt1 = "Default" THEN 0 ELSE IF p-Opt1 = "Portrait" THEN 1 ELSE IF p-Opt1 = "Landscape" THEN 2 ELSE 0. l-printorientation = lp-int1. END. /* of mode orientation */ WHEN "PreviewMode":U THEN DO: /* Option1 is print mode. Opt2-Opt4 are meaningless. */ lp-Int1 = IF p-Opt1 = "Preview" THEN 0 /* Whole doc with preview. */ ELSE IF p-Opt1 = "Direct" THEN 2 /* Whole doc direct to printer */ ELSE IF p-Opt1 = "PageByPage" THEN 4 /* Whole doc but pg by pg. */ ELSE 0. END. /* of mode print mode */ WHEN "ENABLEPRINTERDIALOG":U THEN DO: /* Option1 is on or off. nothing else */ lp-Int1 = IF p-Opt1 = "On" THEN 1 ELSE 0. END. /* PrinterDialog */ WHEN "SHOWPRINTSTATUS":U THEN DO: /* Option1 is on or off. nothing else */ lp-Int1 = IF p-Opt1 = "On" THEN 1 ELSE IF p-Opt1 = "NoCancel" THEN 2 ELSE 0. END. /* ShowPrintStatus */ END CASE. /* p-mode */ RUN VpPrintOptions ( CAPS(p-Mode), lp-Int1, lp-Int2, lp-Int3, lp-Char1, OUTPUT p-err ). IF p-err <> 0 THEN RETURN ERROR "PrintOptions(SetPageOrientation/SetPreviewMode/SetPrinterDialogMode): Error". END. /* of printoptions. */ /* Define a wrapper for the printmode orientation. */ PROCEDURE vpr_SetPageOrientation: DEF INPUT PARAM p-Orientation AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN vpr_PrintOptions ("Orientation", p-Orientation, "", "", ""/*, OUTPUT p-err*/). END PROCEDURE. /* setorientation */ /* Define a wrapper for the previewmode. */ PROCEDURE vpr_SetPreviewMode: DEF INPUT PARAM p-Previewmode AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN vpr_PrintOptions ("Previewmode", p-Previewmode, "", "", ""/*, OUTPUT p-err*/). END PROCEDURE. /* setorientation */ /* SetPrinterAttrib - fancier print options handling :-)))) 07.04.1998 jpc 11.10.1999 jpc - added l_PAFLAG to see which values are valid */ PROCEDURE vpr_SetPrinterAttrib: DEF INPUT PARAM p-Attribs AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO INIT 0. DEF VAR c_entry AS CHAR NO-UNDO. DEF VAR c_entry_left AS CHAR NO-UNDO. DEF VAR c_entry_rite AS CHAR NO-UNDO. DEF VAR i_copies AS INT NO-UNDO. DEF VAR i_from AS INT NO-UNDO. DEF VAR i_to AS INT NO-UNDO. DEF VAR i_tofile AS INT NO-UNDO. DEF VAR i_sort AS INT NO-UNDO. DEF VAR c_name AS CHAR NO-UNDO. DEF VAR i_duplex AS INT NO-UNDO INIT 0. DEF VAR ptr_PrinterAttrib AS MEMPTR. DEF VAR ii AS INT NO-UNDO. DEF VAR ij AS INT NO-UNDO. DEF VAR l_PAFLAGS AS INT NO-UNDO INIT 0. ij = NUM-ENTRIES(p-attribs). DO ii = 1 TO ij: c_entry = TRIM(ENTRY(ii,p-attribs)). c_entry_left=TRIM(ENTRY(1,c_entry,"=")). c_entry_rite=TRIM(ENTRY(2,c_entry,"=")). CASE c_entry_left: WHEN "Copies" THEN DO: i_copies = INT(c_entry_rite). l_PAFLAGS = l_PAFLAGS + 1 . END. WHEN "From" THEN DO: i_from = INT(c_entry_rite). l_PAFLAGS = l_PAFLAGS + 2 . END. WHEN "To" THEN DO: i_to = INT(c_entry_rite). l_PAFLAGS = l_PAFLAGS + 4 . END. WHEN "ToFile" THEN DO: i_toFile = IF (c_entry_rite = "YES" OR c_entry_rite = "TRUE") THEN 1 ELSE 0. l_PAFLAGS = l_PAFLAGS + 8 . END. WHEN "Sort" THEN DO: i_sort = IF (c_entry_rite = "YES" OR c_entry_rite = "TRUE") THEN 1 ELSE 0. l_PAFLAGS = l_PAFLAGS + 16 . END. WHEN "PrinterName" THEN DO: c_name = c_entry_rite. l_PAFLAGS = l_PAFLAGS + 32 . END. WHEN "FileName" THEN DO: c_name = c_entry_rite. l_PAFLAGS = l_PAFLAGS + 32 . END. WHEN "FileTo" THEN DO: c_name = c_entry_rite. l_PAFLAGS = l_PAFLAGS + 32 . END. WHEN "Name" THEN DO: c_name = c_entry_rite. l_PAFLAGS = l_PAFLAGS + 32 . END. WHEN "Duplex" THEN DO: i_duplex = INT(c_entry_rite). END. END CASE. END. /* Now setup the structure */ /* struct PrinterAttrib { WORD size; // size of the structure BYTE ver; // version of the structure WORD copies; // number of copies to print WORD from; // first page WORD to; // last page BYTE sort; // sort output? BYTE toFile; // send output to file instead of printer? WORD paflags; // what's been set? WORD sizeOfName;// size of the following string char name[xxx]; // file or printer name } */ SET-SIZE(ptr_PrinterAttrib)=16 + LENGTH(c_name). /* one extra byte for terminating NULL */ PUT-SHORT(ptr_PrinterAttrib,1) =16 + LENGTH(c_name). PUT-BYTE(ptr_PrinterAttrib,3)=2. /* version 2 */ PUT-SHORT(ptr_PrinterAttrib,4)=i_copies. PUT-SHORT(ptr_PrinterAttrib,6)=i_from. PUT-SHORT(ptr_PrinterAttrib,8)=i_to. PUT-BYTE(ptr_PrinterAttrib,10)=i_sort. PUT-BYTE(ptr_PrinterAttrib,11)=i_toFile. PUT-SHORT(ptr_PrinterAttrib,12)=l_PAFLAGS. PUT-SHORT(ptr_PrinterAttrib,14)=LENGTH(c_name). PUT-STRING(ptr_PrinterAttrib,16)=c_name. RUN VpSetPrinterAttrib (ptr_PrinterAttrib,i_duplex). IF p-err <> 0 THEN RETURN ERROR "SetPrinterAttrib: Error". END. /************************** * Fetch Printer Attributes * **************************/ /* 28.05.98 */ PROCEDURE vpr_FetchPrinterAttrib: DEF INPUT PARAM p_attrib AS CHAR NO-UNDO. DEF OUTPUT PARAM p_value AS CHAR NO-UNDO. DEFINE VARIABLE lp-val AS INT NO-UNDO. RUN VpGetPrinterAttrib(CAPS(p_attrib), OUTPUT lp-val). p_value = TRIM(STRING(lp-val)). END. /************************************* * dialog and user interaction stuff * *************************************/ /* show printer setup dialog */ PROCEDURE vpr_PrinterSetup: DEF VAR p-err AS INT NO-UNDO. RUN VpPrinterSetup(OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "PrinterSetup: Error". END. /* show printer dialog */ PROCEDURE vpr_PrinterDialog: DEF OUTPUT PARAM lButton AS LOGICAL NO-UNDO. DEF VAR iButton AS INT NO-UNDO. RUN VpPrinterDialog(OUTPUT iButton). /* Error-Tracking. */ IF iButton = -1 THEN RETURN ERROR "PrinterDialog: Error". lButton = IF iButton = 0 THEN FALSE ELSE TRUE. END. /* Define a wrapper for the printmode PrinterDialog. */ PROCEDURE vpr_SetPrinterDialogMode: DEF INPUT PARAM p-PrintDlg AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN vpr_PrintOptions ("ENABLEPRINTERDIALOG", p-PrintDlg, "", "", ""/*, OUTPUT p-err*/). END PROCEDURE. /* SetPrinterDialogMode */ /*************************** * Document control stuff * ***************************/ /* * SetDocTitle - set the title of a viper document * 04.10.2001 jc */ PROCEDURE vpr_SetDocTitle: DEF INPUT PARAM p-title AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSetDocTitle(p-title, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetDocTitle: Error". END. /* Reset whole document, reads actual printer setup. */ PROCEDURE vpr_ResetDoc: DEF VAR p-err AS INT NO-UNDO. RUN VpDeleteAll(OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "ResetDoc: Error". END. /* EndDoc - Tell viper that the document is over... 19.1.98 jpc */ PROCEDURE vpr_EndDoc: DEF VAR p-err AS INT NO-UNDO. RUN VpEndDoc(OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "EndDoc: Error". END. /* SaveDoc - save a document to a File 29.04.98 jpc */ PROCEDURE vpr_SaveDoc: DEF INPUT PARAM p-sFileName AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpSaveDoc(p-sFileName, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "SaveDoc: Error". END. /* OpenDoc - loads a document to a File 29.04.98 jpc */ PROCEDURE vpr_OpenDoc: DEF INPUT PARAM p-sFileName AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpOpenDoc(p-sFileName, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "OpenDoc: Error". END. /* ExportDoc - save a document to a File 23.08.02 jc */ PROCEDURE vpr_ExportDoc: DEF INPUT PARAM p-from AS INT NO-UNDO. DEF INPUT PARAM p-to AS INT NO-UNDO. DEF INPUT PARAM p-fname AS CHAR NO-UNDO. DEF INPUT PARAM p-type AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpExportDoc(p-from, p-to, p-fname, p-type, OUTPUT p-err). /* Error-Tracking. */ IF p-err <> 0 THEN RETURN ERROR "ExportDoc: Error". END. /********************************* * MISC stuff i can't find a * * better place for * *********************************/ /* ViperDEBUG - some 'commands' to see some internal Viper stuff */ /* 27.04.98 jpc */ /* 'commands' so far known to ViperDEBUG - Params DISPLAY_PAGE_SIZE - No Params */ PROCEDURE vpr_ViperDEBUG: DEF INPUT PARAM p-commands AS CHAR NO-UNDO. DEF INPUT PARAM p-paramList AS CHAR NO-UNDO. DEF VAR p-err AS INT NO-UNDO. RUN VpDEBUG (CAPS(p-commands), CAPS(p-paramlist), OUTPUT p-err). END PROCEDURE. /* dump the document contents 21.02.05 jc */ PROCEDURE vpr_DebugDumpDocument: DEF INPUT PARAM p-file AS CHAR NO-UNDO. DEFINE VARIABLE p-err AS INT NO-UNDO. RUN VpDebugDumpDocument(p-file, OUTPUT p-err). END PROCEDURE. /********************************* * helper functions of all kinds * *********************************/ PROCEDURE vpr_ShowDLLVersion: DEF VAR lp-ver AS INT NO-UNDO. RUN VpShowDLLVersion (OUTPUT lp-ver). END. /* Change an color string in the format "red,green,blue" to an int. Instead of comma seperated list the v6 colors are allowed. */ PROCEDURE vpr_CalcCol: DEF INPUT PARAM p-ColChar AS CHAR NO-UNDO. DEF OUTPUT PARAM p-ColInt AS INT NO-UNDO. /* There are some predefined colors. These are the colors which are known until V6 from progress. (without light-yellow). */ CASE p-ColChar: WHEN "Light-Gray" THEN p-ColChar = "225,225,225". WHEN "Gray" THEN p-ColChar = "128,128,128". WHEN "Dark-Gray" THEN p-ColChar = "100,100,100". WHEN "Black" THEN p-ColChar = "0,0,0". WHEN "White" THEN p-ColChar = "255,255,255". WHEN "Blue" THEN p-ColChar = "0,0,255". WHEN "Light-Blue" THEN p-ColChar = "128,128,255". WHEN "Green" THEN p-ColChar = "0,255,0". WHEN "Light-Green" THEN p-ColChar = "128,255,128". WHEN "Cyan" THEN p-ColChar = "0,255,255". WHEN "Light-Cyan" THEN p-ColChar = "128,255,255". WHEN "Red" THEN p-ColChar = "255,0,0". WHEN "Light-Red" THEN p-ColChar = "255,128,128". WHEN "Magenta" THEN p-ColChar = "255,0,255". WHEN "Light-Magenta" THEN p-ColChar = "255,128,255". WHEN "Brown" THEN p-ColChar = "119,43,26". WHEN "Light-Brown" THEN p-ColChar = "165,91,50". WHEN "Yellow" THEN p-ColChar = "255,255,0". WHEN "Light-Yellow" THEN p-ColChar = "255,255,128". WHEN "" THEN p-ColChar = "0,0,0". /* Avoid Errors with empty fiels. */ WHEN ? THEN p-ColChar = "0,0,0". /* Avoid Errors with empty fiels. */ END CASE. /* There must be three parts be defined. But we do !not! check for errors. */ p-ColInt = INT(TRIM(ENTRY(1, p-ColChar))) /* red */ + ( 256 * INT(TRIM(ENTRY(2, p-ColChar))) ) /* green */ + ( 65536 * INT(TRIM(ENTRY(3, p-ColChar))) ) NO-ERROR. /* Blue */ IF ERROR-STATUS:ERROR THEN DO: p-ColInt = INT(TRIM(ENTRY(1, p-ColChar, ":"))) /* red */ + ( 256 * INT(TRIM(ENTRY(2, p-ColChar, ":"))) ) /* green */ + ( 65536 * INT(TRIM(ENTRY(3, p-ColChar, ":"))) ) NO-ERROR. /* Blue */ IF ERROR-STATUS:ERROR THEN DO: MESSAGE "Viper: Error in color-string (~"" + p-ColChar + "~"). Setting to default color (~"0:0:0~")" VIEW-AS ALERT-BOX INFO BUTTONS OK. p-ColInt = 0. END. END. END PROCEDURE. /* calccol */ /* Change an attribute string to an format number. */ PROCEDURE vpr_CalcFormat: DEF INPUT PARAM p-Attr AS CHAR NO-UNDO. DEF OUTPUT PARAM p-Form AS INT NO-UNDO. DEF VAR ii AS INT NO-UNDO. DO ii = 1 TO NUM-ENTRIES(p-Attr): p-Form = p-Form + IF ENTRY(ii, p-Attr) = "italic" THEN 1 ELSE IF ENTRY(ii, p-Attr) = "underline" THEN 2 ELSE IF ENTRY(ii, p-Attr) = "strikeout" THEN 4 ELSE IF ENTRY(ii, p-Attr) = "bold" THEN 8 ELSE 0. END. IF p-Form >= 16 THEN p-Form = 15. /* Not to much */ END PROCEDURE. /* calcformat */ /* External windooze procedures. */ PROCEDURE LoadLibraryA EXTERNAL "kernel32.dll": DEF INPUT PARAM p-name AS CHAR NO-UNDO. DEF RETURN PARAM p-dll AS LONG NO-UNDO. END. PROCEDURE FreeLibrary EXTERNAL "kernel32.dll": DEF INPUT PARAM p-dll AS LONG NO-UNDO. END. /* * from now on I simple add new procedure to the end of the file * the old sort order isn't helpful anymore, so with this order, * we can at least easily find the last additions to viper * 03.05.05 jc */ PROCEDURE vpr_SetDocAttrib: DEFINE INPUT PARAM p-attriblist AS CHAR NO-UNDO. DEFINE VARIABLE lp-err AS INTEGER NO-UNDO. RUN VpSetDocAttrib(p-attriblist, OUTPUT lp-err). /* Error-Tracking. */ IF lp-err <> 0 THEN RETURN ERROR "SetDocAttrib: Error". END. /* return the height needed to print all of the cells' text */ PROCEDURE vpr_FetchCellTextHeight: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-height AS INT NO-UNDO. RUN VpGetCellTextHeight(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). IF p-height = -1 THEN RETURN ERROR "FetchCellTextHeight: Error". END. /* return the width necessary to print the cells' text */ PROCEDURE vpr_FetchCellTextWidth: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-height AS INT NO-UNDO. RUN VpGetCellTextWidth(CAPS(p-cell), CAPS(p-group), OUTPUT p-height). IF p-height = -1 THEN RETURN ERROR "FetchCellTextHeight: Error". END. /* set a viperobj (graphical...) * 13.05.05 jc */ PROCEDURE vpr_SetGraphObj: DEF INPUT PARAM p-objnam AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-type AS CHAR NO-UNDO. DEF INPUT PARAM p-x AS INT NO-UNDO. DEF INPUT PARAM p-y AS INT NO-UNDO. DEF INPUT PARAM p-w AS INT NO-UNDO. DEF INPUT PARAM p-h AS INT NO-UNDO. DEF INPUT PARAM p-attribs AS CHAR NO-UNDO. DEF VAR lp-err AS INT NO-UNDO. RUN VpSetGraphObj(CAPS(p-objnam),CAPS(p-group),CAPS(p-type),p-x,p-y,p-w,p-h,CAPS(p-attribs),OUTPUT lp-err). /* Error-Tracking. */ IF lp-err <> 0 THEN RETURN ERROR "vpr_SetGraphObj: Error". END PROCEDURE. /* set group attributes * currently only one attribute (fixed=true/false) is supported * * 26.05.04 jc */ PROCEDURE vpr_SetGroupAttrib: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attr AS CHAR NO-UNDO. DEF VAR lp-err AS INT NO-UNDO. RUN VpSetGroupAttr(CAPS(p-group), CAPS(p-attr), OUTPUT lp-err). /* Error-Tracking. */ IF lp-err <> 0 THEN RETURN ERROR "vpr_SetGroupAttr: Error". END PROCEDURE. /* * wrapper to keep us from incompatibility with 3.2Beta * where this was named ...Attr instead of ..Attrib */ PROCEDURE vpr_SetGroupAttr: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attr AS CHAR NO-UNDO. RUN vpr_SetGroupAttrib(p-group, p-attr). END PROCEDURE. /* set graphObj attributes * * 27.05.04 jc */ PROCEDURE vpr_SetGraphObjAttrib: DEF INPUT PARAM p-object AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attr AS CHAR NO-UNDO. DEF VAR lp-err AS INT NO-UNDO. RUN VpSetGraphObjAttr(CAPS(p-object), CAPS(p-group), CAPS(p-attr), OUTPUT lp-err). /* Error-Tracking. */ IF lp-err <> 0 THEN RETURN ERROR "vpr_SetGraphObjAttr: Error". END PROCEDURE. /* * wrapper to keep us from incompatibility with 3.2Beta * where this was named ...Attr instead of ..Attrib */ PROCEDURE vpr_SetGraphObjAttr: DEF INPUT PARAM p-object AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-attr AS CHAR NO-UNDO. RUN vpr_SetGraphObjAttrib(p-object, p-group, p-attr). END PROCEDURE. /* get the leftmost position of the bounding rectangle around a group */ PROCEDURE vpr_FetchGroupHPos: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-hpos AS INT NO-UNDO. RUN VpGetGroupHPos(CAPS(p-group), OUTPUT p-hpos). IF p-hpos = -1 THEN RETURN ERROR "FetchGroupHPos: Error". END. /* get the width of the bounding rectangle around a group */ PROCEDURE vpr_FetchGroupWidth: DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF OUTPUT PARAM p-width AS INT NO-UNDO. RUN VpGetGroupHPos(CAPS(p-group), OUTPUT p-width). IF p-width = -1 THEN RETURN ERROR "FetchGroupHPos: Error". END. /* * SetCellLineSpacing - Set the space between lines */ PROCEDURE vpr_SetCellRotation: DEF INPUT PARAM p-cell AS CHAR NO-UNDO. DEF INPUT PARAM p-group AS CHAR NO-UNDO. DEF INPUT PARAM p-angle AS DEC NO-UNDO. DEF VAR p-err AS INT NO-UNDO INIT 0. RUN VpSetCellRotation (CAPS(p-cell), CAPS(p-group), p-angle, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetCellRotation: Error". END. PROCEDURE vpr_GetDefaultPrinter: DEF OUTPUT PARAM p-printer AS CHAR NO-UNDO. DEF VAR p-memory AS MEMPTR NO-UNDO. RUN _VpGetDefaultPrinter(OUTPUT p-memory). p-printer = GET-STRING(p-memory, 1). END. PROCEDURE vpr_SetDefaultPrinter: DEF INPUT PARAMETER p-name AS CHAR. DEF OUTPUT PARAMETER p-ret AS INTEGER. RUN _VpSetDefaultPrinter(p-name, OUTPUT p-ret). END. PROCEDURE vpr_SetTempDir: DEFINE INPUT PARAMETER p-tmpdir AS CHARACTER NO-UNDO. DEFINE VARIABLE p-err AS INTEGER NO-UNDO. RUN VpSetTempDir(p-tmpdir, OUTPUT p-err). IF p-err <> 0 THEN RETURN ERROR "SetTempDir: Error". END. /* * Configuration file included by viper.p. * Allows user to configure certain aspects of * viper */ /* &IF DEFINED(Delimiter) > 0 &THEN &UNDEFINE Delimiter &ENDIF */