Plateforme Level Extreme
Abonnement
Profil corporatif
Produits & Services
Support
Légal
English
VFP code syntax coloring in HTML
Message
Information générale
Forum:
Visual FoxPro
Catégorie:
Autre
Divers
Thread ID:
00355687
Message ID:
00361310
Vues:
40
>>#define CRL chr(13)
>>#define CLRL chr(13)+chr(10)
>
>Nadya, just a little improvement. :)
>The usual names for such a constants are CR and CRLF
>:)

Last try? :)
********************************************************************
*  Description.......: nnHTMLCode
*  Calling Samples...: on key label F9 _cliptext=nnHTMLCode(_cliptext)
*  Parameter List....: lcCode, lcPath, lcBeatify
*  Created by........: Mike Helland
*  Modified by.......: Nadya Nosonovsky 04/18/2000 04:45:16 PM
********************************************************************
lparameters lcCode, lcPath, lcBeatify

if empty(lcCode) or vartype(lcCode)<>'C' && Check if first parameter exists
     return .f.
endif

lnSec=seconds()

if vartype(lcBeatify)<>'C'
     release lcBeatify
     lcBeatify='M' && Mixed
endif

if vartype(lcBeatify)='C' and not inlist(left(upper(lcBeatify),1),'U','L')
     lcBeatify='M' && Mixed
endif

#define FONTBLUE   '<font color=blue>'
#define FONTGREEN  '<font color=green>'
#define FONTEND    '</font>'
#define SYMBOLS    ':;,./\<>+=-{}[]()#*'

local SINGLEQUOTE, DOUBLEQUOTE, LEFTPAR, RIGHTPAR, CRLF

SINGLEQUOTE = chr(39)
DOUBLEQUOTE = chr(34)
LEFTPAR = chr(91)
RIGHTPAR = chr(93)
CRLF  = chr(13)+chr(10) 

private CR
CR= chr(13) && should be seen in aparser

*Do some basic HTML intializing
lcCode = strtran(lcCode, chr(9), space(5))
lcCode = strtran(lcCode, '&', '&')
lcCode = strtran(lcCode, '<', '<')
lcCode = strtran(lcCode, '>', '>')

lcCode = strtran(lcCode, CR, CR+CR) && To proper handle blank lines

*Create an array ouf of our strings.
local laLines[1], lcReturn, lnLines, lnI, lcLine, lnWA

local lcComment, lcBeforeComment, lnWords, lcResult

local lcDoubleAmp, lnStartComment, k, lcLeft, lcRight, lcSymb, llStartString, lcRightPrev

private chr254, space1 && in order to be seen in aparser

chr254=chr(254)
space1=space(1)

lnLines=alines(laLines, lcCode)

lcReturn = '<pre>'

lnWA=select()

if !used('words')
     use (iif(empty(lcPath), '', lcPath) + 'words') in 0 order tag revword
endif

*Proccess each line
for lnI = 1 to lnLines

     lcLine = laLines[lnI]

*Don't even bother the blank ones
     if empty(alltrim(lcLine))
          lcReturn = lcReturn +CRLF
          loop
     endif

*Full Line Comments, first
     if left(alltrim(lcLine),1) = '*'
          lcLine = FONTGREEN + lcLine + FONTEND

*Print line here
          lcReturn = lcReturn + CRLF + lcLine
          loop
     endif

     lcComment=''
     lcBeforeComment=lcLine

*Now end of the line comments

     lcDoubleAmp = '&&' && This is to test our function

     lnStartComment = at(lcDoubleAmp, lcLine)

     if lnStartComment > 0
          lcComment = FONTGREEN+substr(lcLine, lnStartComment) + FONTEND && Insert comment tag
          lcBeforeComment=substr(lcLine, 1,lnStartComment-1)
     endif

*!* Devide string into words
    dimension laWords[1] 
     lnWords = aparser(@laWords, lcBeforeComment,SYMBOLS)

     lcResult=''

     for k=1 to lnWords

* First check if we're in a string

        laWords[k]=chrtran(laWords[k],chr254,space1)

          lcLeft=left(laWords[k],1)

          llStartString=.f.

          if inlist(lcLeft,DOUBLEQUOTE,SINGLEQUOTE,LEFTPAR) && String starts
               llStartString=.t.
               if lcLeft=LEFTPAR
                    lcLeft=RIGHTPAR
               endif
               lcSymb=lcLeft
          endif

          do while llStartString && Check if we're still in string

               if k<lnWords
                lcLeft=left(laWords[k+1],1)
                lcRight=right(alltrim(laWords[k+1]),1)
                lcRightPrev=right(alltrim(laWords[k]),1)

                laWords[k]=chrtran(laWords[k],chr254,space1)        

                    if lcSymb==lcLeft or lcSymb==lcRight or ;
                        (len(laWords[k])>1 and lcSymb==lcRightPrev)

                    lcSymb=''
                    lcResult=lcResult+laWords[k]
                    k=k+1
                         llStartString=.f. && String ends
                         exit
                    endif

                   lcResult=lcResult+laWords[k]

                    k=k+1 && Increment count

               else
                   laWords[k]=chrtran(laWords[k],chr254,space1)        
                lcSymb=''
                    llStartString=.f. && String ends
                    exit
               endif
          enddo

        laWords[k]=chrtran(laWords[k],chr254,space1)       

          if not empty(laWords[k]) and seek(upper(padr(alltrim(laWords[k]),22)),'words','revword') && Word found
               do case
               case left(upper(lcBeatify),1)='U' && Upper case
                    laWords[k]=upper(laWords[k])
               case left(upper(lcBeatify),1)='L' && Lower case
                    laWords[k]=lower(laWords[k])
               endcase
               laWords[k]=FONTBLUE+laWords[k]+FONTEND 
          endif
          lcResult=lcResult+laWords[k]
     next

     if not empty(lcBeforeComment) and not empty(lcResult)
          lcBeforeComment=lcResult
     endif

*Submit the process line
     lcReturn = lcReturn  + CRLF + lcBeforeComment+lcComment && Another In Line Test to use
endfor

lcReturn = lcReturn  + '</pre>'

use in words
select (lnWA)
wait window nowait 'Transformed  '+alltrim(str(lnLines))+' lines in '+alltrim(str(seconds()-lnSec,10,6))+' sec'
return lcReturn

**********************************************************************
function aparser
*  Description.......: Function parses a text string into an array.
*                    : Each element of the array contains one word...
*  Calling Samples...: dimension laWords[1]
*                    : lcWordString = "Some text string"
*                    : lnWords = aparser(@laWords, lcWordString)
*  Parameter List....: paWords, pcWordString, pcDelimiter
********************************************************************
lparameter paWords, pcWordString, pcDelimiter
local lnWords, i, lcSymbol

external array paWords

if vartype(pcDelimiter)<>'C'
     pcDelimiter=space1
endif

pcWordString=strtran(pcWordString, space1, space1+chr254) && Replace space(1) with rare symbol chr(254)

for i=1 to len(pcDelimiter)
     lcSymbol=substr(pcDelimiter,i,1)
     pcWordString=strtran(pcWordString,lcSymbol,space1+lcSymbol+space1)  && Larry Miller suggested
next

*!* Replace the delimiter with CHR(13) using STRTRAN.
pcWordString = strtran(pcWordString, space1, CR)

*!* Now put each element in an array.
lnWords=alines(paWords, pcWordString)

return lnWords
If it's not broken, fix it until it is.


My Blog
Précédent
Répondre
Fil
Voir

Click here to load this message in the networking platform