/* RTF1_0.fw.rexx
 *
 * Final writer ARexx script to create an RTF file from the current document
 *
 * v1.0 - WIP
 * Dan Pidcock
 * 2 May - 3 Oct 1996
 */

/* address FinalW.1 */

Options Results

SetMeasure Micropoints

/* Get a filename to use */
Status Pathname
TempFile = Result
/* remove any file extension and add .rtf */
DotPos = lastpos('.', TempFile)
IF (DotPos > 0) THEN DO
  DotPos = DotPos - 1
  TempFile = left(TempFile, DotPos)
END
defaultfile = TempFile || '.rtf'
RequestText '"RTF Exporter"' '"Enter RTF filename:"' defaultfile
IF ( RC ~= 0 ) THEN EXIT

/* Make sure a filename is entered */
filename = Result
IF ( LENGTH(filename) = 0 ) THEN DO
   ShowMessage 1 1 '"You did not enter a filename." "Exiting..." "" "OK" "" ""'
   EXIT
   END

/* Does the file already exist? */
IF ( EXISTS(filename) ) THEN DO
   firstLine = '"The file <' || filename || '> already exists."'
   secondLine = '"Do you want to replace it?"'
   ShowMessage 2 1 firstLine secondLine '"" "Yes" "No" ""'
   IF ( Result = 2 ) THEN EXIT
   END

/* Open the file. */
IF ( OPEN('RTFFile', filename, 'Write') ) THEN DO
   /* File is opened. */

   /* Store the current section, paragraph and position */
   GetSectionSetup NAME
   PARSE VAR Result OriginalSection
   Status ParaPos
   PARSE VAR Result OrigPara OrigPosn

   CALL RTF_out('RTFFile', '{')
   CALL RTF_header('RTFFile')
   CALL RTF_document('RTFFile')
   CALL RTF_out('RTFFile', '}')

   /* Go to the original section paragraph and position */
   GoToSection OriginalSection
   MoveToPara OrigPara OrigPosn

   /* Close the file */
   CALL CLOSE('RTFFile');

   ShowMessage 1 0 '"RTF Export" "File exported" "" "OK" "" ""'
   END /* end do if file could be opened */
ELSE DO
   /* File could not be opened. */
   firstLine = '"Cannot open file <' || filename || '>."'
   ShowMessage 1 1 firstLine '"" "" "OK" "" ""'
   EXIT
   END

EXIT

RTF_header: PROCEDURE
PARSE ARG filehandle
   CALL RTF_out( filehandle, '\rtf')
   /* do character set (use mac as default) */
   CALL RTF_out( filehandle, '\mac')
   /* Font table */
   CALL RTF_fonttbl(filehandle)
return

/* Font table */
RTF_fonttbl: PROCEDURE
PARSE ARG filehandle
   CALL RTF_out(filehandle, '{\fonttbl')
   /* do fontinfo for each font */
   Status NumFonts
   number_fonts = Result
   DO i=1 FOR number_fonts
      CALL RTF_out(filehandle, '{')
      /* fontnum */
      CALL RTF_out(filehandle, '\f' || i-1)
      /* fontfamily */
      Status FontName i
      fname = Result
      CALL Insert_font_fam(filehandle, fname)
      /* fontname */
      CALL RTF_out(filehandle, ' ' || fname)
      CALL RTF_out(filehandle, ';}')
   END
   CALL RTF_out(filehandle, '}')
return

/* insert font family of the font passed as 2nd arg */
Insert_font_fam: PROCEDURE
PARSE ARG filehandle, fname
   SELECT;
   WHEN upper(substr(fname,1,7)) = 'COURIER' THEN;
      CALL RTF_out(filehandle, '\fmodern')
   WHEN upper(substr(fname,1,9)) = 'HELVETICA' THEN;
      CALL RTF_out(filehandle, '\fswiss')
   WHEN upper(substr(fname,1,13)) = 'NC_SCHOOLBOOK' THEN;
      CALL RTF_out(filehandle, '\froman')
   WHEN upper(substr(fname,1,8)) = 'SOFTSANS' THEN;
      CALL RTF_out(filehandle, '\fswiss')
   WHEN upper(substr(fname,1,9)) = 'SOFTSERIF' THEN;
      CALL RTF_out(filehandle, '\froman')
   WHEN upper(substr(fname,1,6)) = 'SYMBOL' THEN;
      CALL RTF_out(filehandle, '\ftech')
   WHEN upper(substr(fname,1,5)) = 'TIMES' THEN;
      CALL RTF_out(filehandle, '\froman')
   OTHERWISE;
      CALL RTF_out(filehandle, '\fnil')
   END
return

/* document */
RTF_document: PROCEDURE
PARSE ARG filehandle
   CALL RTF_info(filehandle)
   CALL RTF_docfmt(filehandle)
   /* do sections */
   GetSectionList '~'
   SList = Result
   SList = translate(SList,' ~','~ ') /* Exchange spaces and tildes */
   NSects = words(SList)
   DO i=1 FOR NSects
      SName = translate(word(SList, i),' ','~')
      CALL RTF_section(filehandle, SName)
      IF i < NSects THEN
         CALL RTF_out(filehandle, '\sect ')
   END
return

RTF_info: PROCEDURE
PARSE ARG filehandle
   CALL RTF_out(filehandle, '{\info{\doccomm Exported from Final Writer by RTF writer 0.3 WIP by Dan Pidcock}}')
return

RTF_docfmt: PROCEDURE
PARSE ARG filehandle
   /* page information */
   GetPageSetup WIDTH
   CALL RTF_out(filehandle, '\paperw' || Result * 2)
   GetPageSetup HEIGHT
   CALL RTF_out(filehandle, '\paperh' || Result * 2)
   GetPageSetup LEFT
   CALL RTF_out(filehandle, '\margl' || Result * 2)
   GetPageSetup RIGHT
   CALL RTF_out(filehandle, '\margr' || Result * 2)
   GetPageSetup TOP
   CALL RTF_out(filehandle, '\margt' || Result * 2)
   GetPageSetup BOTTOM
   CALL RTF_out(filehandle, '\margb' || Result * 2)
   GetPageSetup PAGES
   IF Result == 'LeftRight' THEN
      CALL RTF_out(filehandle, '\facingp')
   GetPageSetup ORIENT
   IF Result == 'Wide' THEN
      CALL RTF_out(filehandle, '\landscape')
   GetPageSetup FIRSTPAGE
      CALL RTF_out(filehandle, '\pgnstart' || Result)
return

/* section */
RTF_section: PROCEDURE
PARSE ARG filehandle, SName

   GoToSection SName
   CALL RTF_secfmt(filehandle)

   /* get the number of paragraphs */
   /* move to end of document */
   CtrlDown
   AltDown
   Cursor Down
   Status ParaPos
   PARSE VAR Result LastPara LastPos
   CtrlUp
   Altup

   Para = 1

   /* do the paragraphs */
   do while (Para <= LastPara)
       CALL RTF_para(filehandle, Para)
       Para = Para + 1
       MoveToPara Para 0
   end

return

/* section format */
RTF_secfmt: PROCEDURE
PARSE ARG filehandle
   CALL RTF_out(filehandle, '\sectd')
   /* Columns */
   GetSectionSetup COLUMNS
   IF Result ~== 1 THEN DO
      CALL RTF_out(filehandle, '\cols' || Result)
      GetSectionSetup COLUMNGAP
      CALL RTF_out(filehandle, '\colsx' || Result * 2)
   END

   /* Page Information */
   GetSectionSetup INSIDE
   CALL RTF_out(filehandle, '\marglsxn' || Result * 2)
   GetSectionSetup OUTSIDE
   CALL RTF_out(filehandle, '\margrsxn' || Result * 2)
   GetSectionSetup TOP
   CALL RTF_out(filehandle, '\margtsxn' || Result * 2)
   GetSectionSetup BOTTOM
   CALL RTF_out(filehandle, '\margbsxn' || Result * 2)
   /* Page Numbers */
   GetSectionSetup FIRSTPAGE
   CALL RTF_out(filehandle, '\pgnstarts' || Result)
   GetSectionSetup PAGENUMFORMAT
   SELECT;
   WHEN Result = 'Normal' THEN;
      CALL RTF_out(filehandle, '\pgndec')
   WHEN Result = 'RomanUpper' THEN;
      CALL RTF_out(filehandle, '\pgnucrm')
   WHEN Result = 'RomanLower' THEN;
      CALL RTF_out(filehandle, '\pgnlcrm')
   WHEN Result = 'AlphaUpper' THEN;
      CALL RTF_out(filehandle, '\pgnucltr')
   WHEN Result = 'AlphaLower' THEN;
      CALL RTF_out(filehandle, '\pgnlcltr')
   END
return

RTF_para: PROCEDURE
PARSE ARG filehandle, Para

   string = ''
   OldPara = Para
   OldPosition = -1
   Position = 0

   MoveToPara Para 0
   CALL RTF_parfmt(filehandle)

   DO WHILE (Para == OldPara) & (Position ~== OldPosition)
         /* This lot goes at the top as FW returns font
          * info for left of cursor */
         Extract
         char = Result
         OldPara = Para
         OldPosition = Position
         Cursor RIGHT
         Status ParaPos
         PARSE VAR Result Para Position

         /* update font, italic, bold if necessary */
         Status Fontname
         fname = Result
         IF fname ~== OldFname THEN DO
            CALL RTF_out(filehandle, string)
            string = ''
            CALL Insert_FontID_BI(filehandle, upper(fname))
            CALL RTF_out(filehandle, ' ')
            OldFname = fname
         END

         /* update super/sub script if necessary */

         Status FontPosition
         FPos = Result
         IF FPos ~== OldFPos THEN DO
            CALL RTF_out(filehandle, string)
            string = ''
            SELECT;
            WHEN FPos == 'SubScript' THEN;
               CALL RTF_out(filehandle, '\sub ')
            WHEN FPos == 'SuperScript' THEN;
               CALL RTF_out(filehandle, '\super ')
            OTHERWISE;
               CALL RTF_out(filehandle, '\nosupersub ')
            END
            OldFPos = Fpos
         END

         /* update font style if necessary */
         Status FontStyle
         FStyle = Result
         IF FStyle ~== OldFStyle THEN DO
            CALL RTF_out(filehandle, string)
            string = ''
            SELECT;
            WHEN FStyle == 'Underline' THEN;
               CALL RTF_out(filehandle, '\ul ')
            WHEN FStyle == 'DUnderline' THEN;
               CALL RTF_out(filehandle, '\uldb ')
            WHEN FStyle == 'StrikThru' THEN;
               CALL RTF_out(filehandle, '\strike ')
            OTHERWISE;
               CALL RTF_out(filehandle, '\ulnone ')
            END
            OldFStyle = FStyle
         END

         /* update font size if necessary */
         Status FontSize
         FSize = Result
         IF FSize ~== OldFSize THEN DO
            CALL RTF_out(filehandle, string)
            string = ''
            CALL RTF_out(filehandle, '\fs' || FSize * 2 || ' ') /* space before text */
            OldFSize = FSize
         END

         /* output char here (see above for reason) */
         /* handle special characters first */
         SELECT;
            WHEN char == '0a'x THEN DO
               CALL RTF_out(filehandle, string || '0a'x || '\par ')
               string = ''
            END
            WHEN char == '{' THEN
               string = string || '\{'
            WHEN char == '}' THEN 
               string = string || '\}'
            WHEN char == '·' THEN /* bullet */
               string = string || '\bullet'
            OTHERWISE DO
               string = string || char
            END
         END /* select */
   END /* while para == OldPara  & position ~== oldPosition */
   /* clear string to output */
   CALL RTF_out(filehandle, string)

return /* from RTF_para */

/* set character format to plain then insert font ID
 * and Bold & italic if necessary
 * FName is assumed to be in upper case */
Insert_fontID_BI: PROCEDURE
PARSE ARG filehandle, fname
   Status NumFonts
   number_fonts = Result
   DO i=1 FOR number_fonts
      Status FontName i
      fntname = Result
      IF fname = upper(fntname) THEN
         CALL RTF_out(filehandle, '\plain \f' || i-1)
   END
   IF pos('BOLD', fname) ~== 0 THEN
      CALL RTF_out(filehandle, '\b')
   IF pos('ITALIC', fname) ~== 0 THEN
      CALL RTF_out(filehandle, '\i')
return /* from Insert_fontID_BI */

/* paragraph format */
RTF_parfmt: PROCEDURE
PARSE ARG filehandle
   /* set paragraph to defaults */
   CALL RTF_out(filehandle, '\pard ')

   /* get alignment */
   Status Justify
   Alignment = Result
   SELECT;
   WHEN Alignment == 'Right' THEN;
      CALL RTF_out(filehandle, '\qr ')
   WHEN Alignment == 'Full' THEN;
      CALL RTF_out(filehandle, '\qj ')
   WHEN Alignment == 'Center' THEN;
      CALL RTF_out(filehandle, '\qc ')
   OTHERWISE;
      CALL RTF_out(filehandle, '\ql ')
   END

   /* get Indentation */
   Status Indent
   Ind = Result
   if Ind ~== 0 then
      CALL RTF_out(filehandle, '\fi' || Ind * 2 || ' ')

   Status LeftMargin
   Ind = Result
   if Ind ~== 0 then
      CALL RTF_out(filehandle, '\li' || Ind * 2 || ' ')

   Status RightMargin
   Ind = Result
   if Ind ~== 0 then
      CALL RTF_out(filehandle, '\ri' || Ind * 2 || ' ')

   /* Line spacing */
   /* documentation unclear, but word 5 seems to set */
   /* single line as 240, 1.5 as 360, double as 480 */
   Status Spacing
   Spac = Result
   SELECT;
   WHEN Spac == 'OneHalf' THEN;
      CALL RTF_out(filehandle, '\sl360 ')
   WHEN Spac == 'Double' THEN;
      CALL RTF_out(filehandle, '\sl480 ')
   WHEN Spac == 'Variable' THEN; DO
      /* Get the Text Leading */
      Status LineHeight
      LineH = Result
      CALL RTF_out(filehandle, '\sl' || LineH * 2 || '\slmult0')
      END
   OTHERWISE;
      CALL RTF_out(filehandle, '\sl240 ')
   END

return /* from RTF_parfmt */

RTF_out: PROCEDURE
PARSE ARG filehandle, str
   len = WRITECH( filehandle, str)
   IF (len ~= LENGTH(str)) THEN DO
      ShowMessage 1 1 '"Error writing file!" "" "" "OK" "" ""'
      CALL CLOSE( filehandle )
      EXIT
   END
return