Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Recno() Order
Message
 
 
To
16/11/2000 21:59:49
General information
Forum:
Visual FoxPro
Category:
Coding, syntax & commands
Title:
Miscellaneous
Thread ID:
00442673
Message ID:
00443032
Views:
13
>>Hi David,
>>
>>I believe I mentioned Mike Helland mhHTMLCode (available in Files section) hundreds of time already. Actually, I modified his code a little bit to achieve some additional functionality, but unfortunately, I haven't succeed. I would suggest you to download Mike's code+Words table. Bellow is my own modified version, which I use:
>>
>snip...
>
>100's of thanks Nadya.

David & Dragan,

Thanks a million for your help. I just modified this program again and it now works, as I want!!!!!!! Hurray!
********************************************************************
*  Description.......: nnHTMLCode
*  Calling Samples...: on key label F9 _cliptext=nnHTMLCode(_cliptext)
*  Parameter List....: tcCode, tcPath, lcBeatify
*  Created by........: Mike Helland
*  Modified by.......: Nadya Nosonovsky 04/18/2000 04:45:16 PM
********************************************************************
lparameters tcCode, tcPath, lcBeatify

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

lnSec=seconds()

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

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

#define SINGLEQUOTE chr(39)
#define DOUBLEQUOTE chr(34)
#define LEFTPAR     chr(91)
#define RIGHTPAR    chr(93)
#define FONTBLUE    '<font color=blue>'
#define FONTGREEN   '<font color=green>'
#define FONTEND     '</font>'
#define SYMBOLS     ':;,./\<>+=-{}[]()#*'

*Do some basic HTML intializing
tcCode = strtran(tcCode, chr(9), space(5))
tcCode = strtran(tcCode, '&', '&')
tcCode = strtran(tcCode, '<', '<')
tcCode = strtran(tcCode, '>', '>')
tcCode = strtran(tcCode, chr(13), chr(13)+chr(13)) && 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

lnLines=alines(laLines, tcCode)

lcReturn = '<pre>'

lnWA=select()

if !used('words')
     use (iif(empty(tcPath), '', tcPath) + '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 +chr(13) + chr(10)
          loop
     endif

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

*Print line here
          lcReturn = lcReturn + chr(13) + chr(10) + 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)
*      suspend
     lcResult=''

     for k=1 to lnWords

* First check if we're in a string

          laWords[k]=chrtran(laWords[k],chr(254),space(1))

          lcLeft=left(laWords[k],1)
            lcRight=right(laWords[k],1)           

          llStartString=.f.

          if inlist(lcLeft,DOUBLEQUOTE,SINGLEQUOTE,LEFTPAR) && String starts
                 if lcLeft=lcRight and len(laWords[k])>1
                       llStartString=.f.
                  else     
                     llStartString=.t.
                endif     
               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)
                    if len(laWords[k+1])>1
                         lcRight=right(alltrim(laWords[k+1]),1)
                    else
                         lcRight=left(laWords[k+1],1)
                        endif
                    laWords[k]=chrtran(laWords[k],chr(254),space(1))

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

                    lcResult=lcResult+laWords[k]

                    k=k+1 && Increment count

               else && k=LnWords
                    laWords[k]=chrtran(laWords[k],chr(254),space(1))
                    lcSymb=''
                    llStartString=.f. && String ends
                    exit
               endif
          enddo

          laWords[k]=chrtran(laWords[k],chr(254),space(1))

          if not empty(laWords[k]) and seek(upper(padr(alltrim(laWords[k]),22)),'words','revword') && Word found
               do case
               case left(upper(tcBeautify),1)='U' && Upper case
                    laWords[k]=upper(laWords[k])
               case left(upper(tcBeautify),1)='L' && Lower case
                    laWords[k]=lower(laWords[k])
               endcase
               laWords[k]=FONTBLUE+laWords[k]+FONTEND
          endif
          lcResult=lcResult+laWords[k]
     next
pcTest1='This is to test [strings ] Local private empty seek'
     if not empty(lcBeforeComment) and not empty(lcResult)
          lcBeforeComment=lcResult
     endif

*Submit the process line
     lcReturn = lcReturn  + chr(13) + chr(10) + 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=space(1)
endif

pcWordString=strtran(pcWordString,space(1), space(1)+chr(254)) && Replace space(1) with rare symbol chr(254)
pcTest=[This is a local variable space test] && To Test
for i=1 to len(pcDelimiter)
     lcSymbol=substr(pcDelimiter,i,1)
     pcWordString=strtran(pcWordString,lcSymbol,space(1)+lcSymbol+space(1))  && Larry Miller suggested
next

*!* Replace the delimiter with CHR(13) using STRTRAN.
pcWordString = strtran(pcWordString, space(1), chr(13))

*!* 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
Previous
Reply
Map
View

Click here to load this message in the networking platform