'===========================================================================
' Subject: RTF COMMON CONTROL FUNCTIONS      Date: 12-09-98 (14:35)       
' Author:  Don Dickinson                     Code: PBDLL                  
' Origin:  ddickinson@usinternet.com       Packet: PBDLL.ABC
'===========================================================================
'
'  RTFFUNCT.BAS
'
'  Rich Edit Common Control Function Wrappers for PB/DLL 5.
'
'     PrintRichTextBox     Prints the contents of a rich text box
'     SetRTFText           Fills a rich edit box from an rtf or text file
'     SaveRTFText          Saves the contents of a rich edit box as an RTF file
'
'  Last Revision:    Jan. 1998
'
'  Written by:       Don Dickinson
'                    ddickinson@usinternet.com
'                    http://ourworld.compuserve.com/homepages/ddickinson
'
'  This module is free for public use without acknowledging the
'  author - Don Dickinson. It is provided, as is, for use and abuse.
'  Use at your own risk. The author assumes no responsibility
'  for any effects or side-effects of using this code.
'
'  Requires WIN32API.INC
'
'  Function Forwards
'
DECLARE SUB PrintRichTextBox( hWnd AS LONG, hInst AS LONG, rtfEdit AS LONG, LM AS SINGLE, _
                              RM AS SINGLE, TM AS SINGLE, BM AS SINGLE )
DECLARE FUNCTION SetRTFText( rtfEdit AS LONG, _
                             sFileName AS STRING, iAttrib AS INTEGER ) AS INTEGER
DECLARE FUNCTION ReadStreamCallback( BYVAL dwCookie AS DWORD, _
                                     pbBuffer AS BYTE PTR, _
                                     BYVAL cb AS LONG, _
                                     pcb AS LONG ) AS DWORD
DECLARE FUNCTION SaveRTFText( rtfEdit AS LONG, sFileName AS STRING ) AS INTEGER
DECLARE FUNCTION WriteStreamCallback( BYVAL dwCookie AS DWORD, _
                                      pbBuffer AS BYTE PTR, _
                                      BYVAL cb AS LONG, _
                                      pcb AS LONG ) AS DWORD
'========================================================================================
SUB PrintRichTextBox( hWnd AS LONG, hInst AS LONG, rtfEdit AS LONG, LM AS SINGLE, _
                      RM AS SINGLE, TM AS SINGLE, BM AS SINGLE )
   '
   '  Purpose:
   '           Prints the contents of an RTF text box given it's handle, the
   '           calling program's handle(s), and the page margins.
   '
   '  Parameters:
   '           hWnd     = Parent window (used for print common dlg)
   '           hInst    = Instance of calling program
   '           rtfEdit  = Handle of rich edit control
   '           LM       = Left Margin in inches
   '           RM       = Right Margin in inches
   '           TM       = Top Margin in inches
   '           BM       = Bottom Margin in inches
   '
  DIM fr AS FORMATRANGE
  DIM rDocInfo AS DOCINFO
  DIM iTextOut AS LONG
  DIM iTextAmt AS LONG
  DIM pd AS PRINTDLGAPI
  DIM zString AS ASCIIZ * 200
  DIM iWidthTwips&
  DIM iHeightTwips&
   '- Setup the print common dialog
  pd.lStructSize = LEN( pd )
  pd.hwndOwner = hWnd
  pd.hDevMode = %NULL
  pd.hDevNames = %NULL
  pd.nFromPage = 0
  pd.nToPage = 0
  pd.nMinPage = 0
  pd.nMaxPage = 0
  pd.nCopies = 0
  pd.hInstance = hInst
  pd.Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_PRINTSETUP
  pd.lpfnSetupHook = %NULL
  pd.lpPrintSetupTemplateName = %NULL
  pd.lpfnPrintHook = %NULL
  pd.lpPrintTemplateName = %NULL

  IF PrintDlg( pd ) THEN
    SetCursor LoadCursor( %NULL, BYVAL %IDC_WAIT )
      '- Fill format range structure
      '
      '  NOTE:
      '     This gave me fits. I was looking at the book from
      '     Microsoft Press called Programming the Windows 95
      '     Iterface. It said (via example) that the
      '     Rectagle was defined in Pixels. This didn't work right.
      '     The SDK, however, said the measurements needed to be
      '     in Twips! This seems to work fine.
      '
      '
    fr.hdc = pd.hDC
    fr.hdcTarget = pd.hDC
    fr.chrg.cpMin = 0
    fr.chrg.cpMax = - 1
    fr.rc.nTop = TM * 1440
    fr.rcPage.nTop = fr.rc.nTop
    fr.rc.nLeft = LM * 1440
    fr.rcPage.nLeft = fr.rc.nLeft
      '- Get page dimensions in Twips
    iWidthTwips& = INT(( GetDeviceCaps( pd.hDC, %HORZRES ) / GetDeviceCaps( pd.hDC, %LOGPIXELSX )) * 1440 )
    iHeightTwips& = INT(( GetDeviceCaps( pd.hDC, %VERTRES ) / GetDeviceCaps( pd.hDC, %LOGPIXELSY )) * 1440 )
    fr.rc.nRight = iWidthTwips& - RM * 1440
    fr.rcPage.nRight = fr.rc.nRight
    fr.rc.nBottom = iHeightTwips& - BM * 1440
    fr.rcPage.nBottom = fr.rc.nBottom
      '- Fill rDocInfo structure
    rDocInfo.cbSize = LEN( rDocInfo )
    zString = "RTF Printer"
    rDocInfo.lpszDocName = VARPTR( zString )
    rDocInfo.lpszOutput = %NULL
      '- Here we go
    StartDoc pd.hDC, rDocInfo
    StartPage pd.hDC
      '- This does the printing. We send messages
      '  to the edit box telling it to format it's
      '  text to fit the Printer's DC.
      '
    iTextOut = 0
    iTextAmt = SendMessage( rtfEdit, %WM_GETTEXTLENGTH, 0, 0 )

    DO WHILE iTextOut < iTextAmt
      iTextOut = SendMessage( rtfEdit, %EM_FORMATRANGE, _
      1, VARPTR( fr ))
      IF iTextOut < iTextAmt THEN
        EndPage pd.hDC
        StartPage pd.hDC
        fr.chrg.cpMin = iTextOut
        fr.chrg.cpMax = - 1
      END IF
    LOOP

    SendMessage rtfEdit, %EM_FORMATRANGE, 1, %NULL
      '- Finish the printing.
    EndPage pd.hDC
    EndDoc pd.hDC
    DeleteDC pd.hDC
    SetCursor LoadCursor( %NULL, BYVAL %IDC_ARROW )
  ELSE
        ' MsgBox "Canceled !"
  END IF

END SUB
'========================================================================================
FUNCTION SetRTFText( rtfEdit AS LONG, sFileName AS STRING, iAttrib AS INTEGER ) AS INTEGER
   '
   '  Purpose:
   '           Loads an RTF control with the contents of an RTF file given
   '           the control's window handle and the name of the file.
   '
   '  Parameters:
   '           rtfEdit     =  Handle of a rich edit control
   '           sFileName   =  File name to read
   '           iAttrib     =  Either %SF_TEXT or %SF_RTF - specifies the
   '                          type of file to be read.
   '
   '  Returns:
   '           %True on success
   '           %False if failure
   '
  DIM hFile AS LONG
  DIM eStream AS EDITSTREAM
  DIM ofS AS OFSTRUCT
  ON ERROR RESUME NEXT
  hFile = FREEFILE
  OPEN sFileName FOR BINARY AS #hFile
  IF ERR THEN
        '- unable to open file
    FUNCTION = %False
  ELSE
    eStream.dwCookie = hFile
    eStream.pfnCallback = CODEPTR( ReadStreamCallback )
    eStream.dwError = 0
    SendMessage rtfEdit, %EM_STREAMIN, iAttrib, VARPTR( eStream )
      '- The text box is dirty now ...
    SendMessage rtfEdit, %EM_SETMODIFY, 1, 0
    CLOSE #hFile
    FUNCTION = %True
  END IF
END FUNCTION
'========================================================================================
FUNCTION ReadStreamCallback( BYVAL dwCookie AS DWORD, _
                             pbBuffer AS BYTE PTR, _
                             BYVAL cb AS LONG, _
                             pcb AS LONG ) AS DWORD
  DIM rOver AS OVERLAPPED
  DIM sInput AS STRING
  DIM iBuf AS LONG
  DIM iCopyLen AS LONG
   '- Find out if the amount requested is
   '  beyond the end of the file.
   '
  IF LOF( dwCookie ) - LOC( dwCookie ) < 0 THEN
    iCopyLen = LOF( dwCookie ) - LOC( dwCookie )
  ELSE
    iCopyLen = cb
  END IF
  sInput = SPACE$( iCopyLen )
   '- Incoming data
  GET #dwCookie,, sInput
  pcb = iCopyLen
   '- Yes, this is sort of slow, but
   '  I just whipped this together. You
   '  could use rtlCopyMemory to transfer
   '  the memory more quickly, but I can't
   '  remember it's syntax, so I'll use pointers.
   '
  FOR iBuf = 0 TO iCopyLen - 1
    @pbBuffer = ASC( MID$( sInput, iBuf + 1, 1 ))
    pbBuffer = pbBuffer + 1
  NEXT iBuf
   '- I always return 0. This if non-zero is returned,
   '  it indicates an error occured. For a "real-application"
   '  you probably want to check err for a read error
   '  during the Get operation.
   '
   '  The edit control itself will stop calling this call-back
   '  if one of the following occurs ...
   '
   '     1. Non-zero is returned
   '     2. zero returned in pcb
   '     3. pcb is less than cb upon return
   '     4. an error occurs transferring data into buffer (out
   '        of memory, etc.)
   '     5. rtf data is invalid.
   '     6. If the edit control is single line and a
   '        crlf pair is copied into the buffer.
   '
  FUNCTION = 0
END FUNCTION
'========================================================================================
FUNCTION SaveRTFText( rtfEdit AS LONG, sFileName AS STRING ) AS INTEGER
   '
   '  Purpose:
   '           Saves the contents of an RTF control to an RTF file given
   '           it's file name and the handle of the control.
   '
   '  Parameters:
   '           rtfEdit     = The handle of the RTF control
   '           sFileName   = The name of the output file.
   '
   '  Returns:
   '           %True if successful
   '           %False otherwise
   '
  DIM hFile AS LONG
  DIM eStream AS EDITSTREAM
  DIM ofS AS OFSTRUCT
  ON ERROR RESUME NEXT
  hFile = FREEFILE
  OPEN sFileName FOR BINARY AS #hFile
  IF ERR THEN
    FUNCTION = %False
  ELSE
    eStream.dwCookie = hFile
    eStream.dwError = 0
    eStream.pfnCallback = CODEPTR( WriteStreamCallback )
    SendMessage rtfEdit, %EM_STREAMOUT, %SF_RTF, VARPTR( eStream )
    FUNCTION = %True
  END IF
END FUNCTION
'========================================================================================
FUNCTION WriteStreamCallback( BYVAL dwCookie AS DWORD, _
                              pbBuffer AS BYTE PTR, _
                              BYVAL cb AS LONG, _
                              pcb AS LONG ) AS DWORD
  DIM sOutput AS STRING
  DIM i AS LONG
  DIM ptrBuffer AS BYTE PTR
  DIM ptrInput AS BYTE PTR
  sOutput = SPACE$( cb )
  ptrBuffer = STRPTR( sOutput )
  ptrInput = pbBuffer
  FOR i = 1 TO cb
    @ptrBuffer = @ptrInput
    INCR ptrBuffer
    INCR ptrInput
  NEXT i
  PUT #dwCookie,, sOutput
END FUNCTION