|
发信人: goodfrd(HAL9000) 整理人: foxzz(2003-02-08 09:31:01), 站内信件 |
| ******************************************************************************
* PRG2HTM.PRG - 把 .PRG 文件转换成 .HTM 格式以便 WEB 方式显示 Ver 1.0 * (C) M.L.Y 2003.1, 2.3 * * 在 WIN98 + VFP 5.0 环境测试通过 ****************************************************************************** SET TALK OFF SET SAFETY ON LOCAL lcPrgFile, lcHtmlFile, lcText, lcHTML, llUpperRevWord IF MESSAGEBOX([把 .PRG 文件转换成 .HTM 格式] + CHR(13) + CHR(13) + ; [是否继续?], 4 + 32 + 256, [.PRG->.HTM]) <> 6 RETURN ENDIF lcPrgFile = GETFILE([PRG], [PRG file:], [Open]) IF EMPTY(lcPrgFile) RETURN ENDIF IF RAT("\", lcPrgFile) > 0 lcHtmlFile = SUBSTR(lcPrgFile, RAT("\", lcPrgFile ) + 1) ENDIF lcHtmlFile = SUBSTR(lcHtmlFile, 1, RAT(".", lcHtmlFile)) + "HTM" lcHtmlFile = PUTFILE("Output:", lcHtmlFile, "HTM") IF EMPTY(lcHtmlFile) RETURN ENDIF IF MESSAGEBOX([是否把保留字全部变成大写？], 4 + 32 + 256, [.PRG->.HTM]) <> 6 llUpperRevWord = .F. ELSE llUpperRevWord = .T. ENDIF lcText = FileToStr(lcPrgFile) lcHTML = PrgCode2Html(lcText, llUpperRevWord) =StrToFile(lcHTML, lcHtmlFile) RETURN ****************************************************************************** * FUNCTION PrgCode2Html * (C) M.L.Y 2003.2.2 * Ref: mhHtmlCode.prg by Mike Helland * * 将 .PRG 格式文件字符串（可把整个文件看作一个字符串）转换为 HTML 格式 * * tcCode - .PRG 文件字符串代码 * tlUpperRevWord - VFP 保留字是否转换成大写 * * 返回字符串 - HTML 格式（出错返回空字符串） * * 保留字表 WORDS.DBF 结构： * 数据记录数: 1563 * 代码页: 1252 * 字段 字段名 类型 宽度 小数位 索引 排序 Nulls * 1 REVWORD 字符型 22 升序 Machine 否 * 列出部分记录内容如下： * list for recno() <= 10 or recno() > reccount() - 10 * 记录号 REVWORD * 1 ABS * 2 ACCEPT * 3 ACCESS * 4 ACLASS * 5 ACOPY * 6 ACOS * 7 ACTIVATE * 8 ACTIVATECELL * 9 ACTIVECOLUMN * 10 ACTIVECONTROL * 1554 _TRANSPORT * 1555 _TRIGGERLEVEL * 1556 _UNIX * 1557 _VFP * 1558 _WEBMENU * 1559 _WINDOWS * 1560 _WIZARD * 1561 _WRAP * 1562 WINDOW * 1563 HOME ****************************************************************************** FUNCTION PrgCode2Html LPARAMETERS tcCode, tlUpperRevWord LOCAL lnSeconds lnSeconds = 0 * Performance checker lnSeconds = SECONDS() LOCAL lcCode, ; lcCRLF, ; lnLines, ; laLines[65000], ; lcReturn, ; lnI, ; lcLine, ; lcNoTabLine, ; lnStartComment, ; lcInlineComment, ; lnStuffedChars, ; llString, ; lcTempLine, ; lnOffset, ; lnWords, ; laWords[1], ; lnWord, ; lnWordStart, ; lcWord, ; lnWordLen, ; lcEndString, ; lcWordsTable, ; lcSepChars * if no code was passed, return blank lcCode = tcCode IF EMPTY(lcCode) RETURN [] ENDIF * If tlUpperRevWord was not passed, default to False IF TYPE('tlUpperRevWord') != 'L' tlUpperRevWord = .F. ENDIF * HTML COLOR: black,olive,teal,red,blue,maroon,navy,gray,lime, * fudrsia,white,green,purple,sliver,yellow,aqua * or: #RRGGBB, i.e.: #1110b9 *ccROOT = "<pre>" ccROOT = "<" + "pre>" *ccROOT = "" *ccCOMMENT = "" ccCOMMENT = "<" + "font color='green'>" ccRESERVED = "<" + "font color='blue'>" ccLITERAL = "<" + "font color='red'>" ccSTRING = "<" + "font color='fudrsia'>" *ccVARIABLE = "" ccVARIABLE = "<" + "font color='maroon'>" ccROOT_CLOSE = "<" + "/pre>" *ccROOT_CLOSE = "" ccCOMMENT_CLOSE = "<" + "/font>" ccRESERVED_CLOSE = "<" + "/font>" ccLITERAL_CLOSE = "<" + "/font>" ccSTRING_CLOSE = "<" + "/font>" ccVARIABLE_CLOSE = "<" + "/font>" cnCOMMENT_LEN = LEN(ccCOMMENT) cnRESERVED_LEN = LEN(ccRESERVED) cnLITERAL_LEN = LEN(ccLITERAL) cnSTRING_LEN = LEN(ccSTRING) cnVARIABLE_LEN = LEN(ccVARIABLE) cnCOMMENT_CLOSE_LEN = LEN(ccCOMMENT_CLOSE) cnRESERVED_CLOSE_LEN = LEN(ccRESERVED_CLOSE) cnLITERAL_CLOSE_LEN = LEN(ccLITERAL_CLOSE) cnSTRING_CLOSE_LEN = LEN(ccSTRING_CLOSE) cnVARIABLE_CLOSE_LEN = LEN(ccVARIABLE_CLOSE) *ccBR = "<br>" ccBR = "" * Do the CRLF now for small performance reasons lcCRLF = CHR(13) + CHR(10) * 分隔符： lcSepChars = '~!@#$%^&*()-+=|\{}:;,./\<>?' + CHR(9) * 先把 回车+换行 转换成 换行 lcCode = STRTRAN(lcCode, CHR(13) + CHR(10), CHR(10)) * 再把 换行+回车 转换成 换行 lcCode = STRTRAN(lcCode, CHR(10) + CHR(13), CHR(10)) * 再把单独的 回车 转换成 换行 lcCode = STRTRAN(lcCode, CHR(13), CHR(10)) *Do some basic HTML intializing lcCode = STRTRAN(lcCode, '&', '&' + 'amp;') lcCode = STRTRAN(lcCode, '<', '&' + 'lt;') lcCode = STRTRAN(lcCode, '>', '&' + 'gt;') *This is one is diffent, so its recognized as a word lcCode = STRTRAN(lcCode, '[', ' [') * 如果最后一行没有换行结尾，补上换行，以便计算行数： IF RIGHT(lcCode, 1) <> CHR(10) lcCode = lcCode + CHR(10) ENDIF lnLines = OCCURS(CHR(10), lcCode) lnOld = 1 FOR lnI = 1 TO lnLines lnPos = AT(CHR(10), lcCode, lnI) lcItem = SUBSTR(lcCode, lnOld, lnPos - lnOld) lnOld = lnPos + 1 laLines[lnI] = lcItem NEXT lnI * 返回 HTML 代码： lcReturn = '' * The words table should be in the same directory as this program lcWordsTable = 'WORDS.DBF' IF FILE(lcWordsTable) IF !USED([words]) USE (lcWordsTable) IN 0 SHARED ALIAS words ENDIF SELECT words ELSE RETURN [] ENDIF *Proccess each line FOR lnI = 1 TO lnLines lcLine = laLines[lnI] *Don't even bother the blank ones IF EMPTY(ALLTRIM(lcLine)) IF lnI = 1 lcReturn = [] ELSE lcReturn = lcReturn + ccBR + lcCRLF ENDIF LOOP ENDIF * Full Line Comments, first are the first test lcNoTabLine = LTRIM(CHRTRAN(UPPER(lcLine), lcSepChars, ; SPACE(LEN(lcSepChars)))) + ' ' IF LTRIM(CHRTRAN(lcLine, CHR(9), '')) = '*' or lcNoTabLine = 'NOTE ' lcLine = REPLICATE([&] + [nbsp;], LEN(lcLine) - LEN(LTRIM(lcLine))) + ; LTRIM(lcLine) IF cnCOMMENT_LEN > 0 lcLine = ccCOMMENT + lcLine + ccCOMMENT_CLOSE ENDIF *And move on IF lnI = 1 lcReturn = lcLine ELSE lcReturn = lcReturn + ccBR + lcCRLF + lcLine ENDIF LOOP ENDIF * Now end of the line comments lnStartComment = AT('&' + '&', lcLine) IF lnStartComment > 0 lcInLineComment = ccCOMMENT + SUBSTR(lcLine, lnStartComment) + ; ccCOMMENT_CLOSE lcLine = SUBSTR(lcLine, 1, lnStartComment - 1) ELSE lcInLineComment = '' ENDIF * Prerun fun lnStuffedChars = 0 llString = .F. *Lets loop through every word in our line. Break the line into words lcTempLine = ' ' + LTRIM(CHRTRAN(UPPER(lcLine), ; lcSepChars, SPACE(LEN(lcSepChars)))) + ' ' * Offset it the number of tabs and spaces leading the line lnOffset = LEN(lcLine) - LEN(lcTempLine) + 1 * Run through each words lnWords = OCCURS(' ', lcTempLine) - 1 DIMENSION laWords[lnWords, 2] FOR lnWord = 1 TO lnWords * Deteremine the word and where it starts and ends lnWordStart = AT(' ', lcTempLine, lnWord) + 1 + lnOffset lcWord = SUBSTR(lcTempLine, lnWordStart - lnOffSet, ; AT(' ', lcTempLine, lnWord + 1) - lnWordStart + ; lnOffSet) lnWordLen = LEN(lcWord) * See what type of word we got DO CASE CASE EMPTY(lcWord) * If we're in a string, don't color the words CASE llString * If this is the end of the string, set it IF RIGHT(lcWord, 1) = lcEndString llString = .F. IF cnSTRING_LEN > 0 lcLine = STUFF(lcLine, ; lnWordStart + lnStuffedChars + ; lnWordLen, ; 0, ccSTRING_CLOSE) lnStuffedChars = lnStuffedChars + cnSTRING_CLOSE_LEN ENDIF ENDIF * See if the word is the beginning of a string using quotes (first * one) or brackets (second case) CASE INLIST(lcWord, '"', "'") * Turn the string flag on, so we don't color words in strings llString = .T. lcEndString = LEFT(lcWord, 1) IF cnSTRING_LEN > 0 * Add the string tag lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars, 0, ; ccSTRING) lnStuffedChars = lnStuffedChars + cnSTRING_LEN * If a string is the beginning and end of a word, * end it now it IF lnWordLen > 1 and RIGHT(lcWord, 1) = lcEndString llString = .F. lcLine = STUFF(lcLine, ; lnWordStart + lnStuffedChars + ; lnWordLen, ; 0, ccSTRING_CLOSE) lnStuffedChars = lnStuffedChars + cnSTRING_CLOSE_LEN ENDIF ENDIF CASE lcWord = '[' llString = .T. lcEndString = ']' * This one is special, we need to insert it before the * preceding space IF cnSTRING_LEN > 0 lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars - 1, ; 0, ccSTRING) lnStuffedChars = lnStuffedChars + cnSTRING_LEN IF lnWordLen > 1 and RIGHT(lcWord, 1) = lcEndString llString = .F. lcLine = STUFF(lcLine, ; lnWordStart + lnStuffedChars + ; lnWordLen, ; 0, ccSTRING_CLOSE) lnStuffedChars = lnStuffedChars + cnSTRING_CLOSE_LEN ENDIF ENDIF * The word is a literal CASE ISDIGIT(lcWord) and TYPE(lcWord) = 'N' IF cnLITERAL_LEN > 0 * Insert the tags and bump the counter lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars, 0, ; ccLITERAL) lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars + ; cnLITERAL_LEN + lnWordLen, 0, ; ccLITERAL_CLOSE) lnStuffedChars = lnStuffedChars + cnLITERAL_LEN + ; cnLITERAL_CLOSE_LEN ENDIF * This is a non colored operator CASE INLIST(UPPER(lcWord) + SPACE(1), 'AND', 'OR', 'NOT', 'NULL') * Don't do anything * Our word is a reserved word CASE SEEK(IIF(lnWordLen < 4, PADR(lcWord, 4), lcWord), 'words', ; 'revword') IF cnRESERVED_LEN > 0 * Insert the tags and bump the counter IF !tlUpperRevWord lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars, ; 0, ccRESERVED) lcLine = STUFF(lcLine, ; lnWordStart + lnStuffedChars + ; cnRESERVED_LEN + lnWordLen, ; 0, ccRESERVED_CLOSE) ELSE lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars, ; lnWordLen, ; ccRESERVED + lcWord + ccRESERVED_CLOSE) ENDIF lnStuffedChars = lnStuffedChars + cnRESERVED_LEN + ; cnRESERVED_CLOSE_LEN ENDIF * Must be a variable OTHERWISE IF cnVARIABLE_LEN > 0 * Insert the tags and bump the counter lcLine = STUFF(lcLine, lnWordStart + lnStuffedChars, 0, ; ccVARIABLE) lcLine = STUFF(lcLine, ; lnWordStart + lnStuffedChars + ; cnVARIABLE_LEN + lnWordLen, ; 0, ccVARIABLE_CLOSE) lnStuffedChars = lnStuffedChars + cnVARIABLE_LEN + ; cnVARIABLE_CLOSE_LEN ENDIF ENDCASE ENDFOR * If a string was left open, close it IF llString lcLine = lcLine + ccSTRING_CLOSE ENDIF lcLine = REPLICATE([&] + [nbsp;], LEN(lcLine) - LEN(LTRIM(lcLine))) + ; LTRIM(lcLine) * Finish out the line IF lnI = 1 lcReturn = lcLine + lcInLineComment ELSE lcReturn = lcReturn + ccBR + lcCRLF + lcLine + lcInLineComment ENDIF ENDFOR * Revert this strange lcReturn = STRTRAN(lcReturn, ' [', '[') * These really slow down the process, choosing a blank Variable color is best * for performance IF cnVARIABLE_LEN > 0 lcReturn = STRTRAN(lcReturn, ; '&' + ccVARIABLE + 'lt' + ccVARIABLE_CLOSE + ';', ; '&' + 'lt;') lcReturn = STRTRAN(lcReturn, ; '&' + ccVARIABLE + 'gt' + ccVARIABLE_CLOSE + ';', ; '&' + 'gt;') lcReturn = STRTRAN(lcReturn, ; '&' + ccVARIABLE + 'amp' + ccVARIABLE_CLOSE + ';', ; '&' + 'amp;') IF cnLITERAL_LEN > 0 lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'T' + ccVARIABLE_CLOSE + '.', ; ccLITERAL + '.T.' + ccLITERAL_CLOSE) lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'F' + ccVARIABLE_CLOSE + '.', ; ccLITERAL + '.F.' + ccLITERAL_CLOSE) lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 't' + ccVARIABLE_CLOSE + '.', ; ccLITERAL + '.t.' + ccLITERAL_CLOSE) lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'f' + ccVARIABLE_CLOSE + '.', ; ccLITERAL + '.f.' + ccLITERAL_CLOSE) ELSE lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'T' + ccVARIABLE_CLOSE + '.', ; '.T.') lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'F' + ccVARIABLE_CLOSE + '.', ; '.F.') lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 't' + ccVARIABLE_CLOSE + '.', ; '.t.') lcReturn = STRTRAN(lcReturn, ; '.' + ccVARIABLE + 'f' + ccVARIABLE_CLOSE + '.', ; '.f.') ENDIF ENDIF * 转换所有的连续2个空格： lcReturn = STRTRAN(lcReturn, SPACE(2), REPLICATE([&] + [nbsp;], 2)) *Return the orginal value so we can pass by ref if we want tcCode = ccROOT + lcReturn + ccROOT_CLOSE USE IN SELECT('words') lnSeconds = SECONDS() - lnSeconds WAIT [转换所用时间 = ] + LTRIM(STR(lnSeconds)) + [ 秒] WINDOW AT 0,20 NOWAIT RETURN tcCode *============================================================================= * VFP 6.0 以上版本才有 FileToStr() 和 StrToFile() #IF VAL(SUBSTR(Version(), ATC("FoxPro",VERSION()) + 7, 2)) <= 5 ****************************************************************************** * FUNCTION FileToStr(tcFileName) * Author: William Kunneke [email protected] * * Reads the contents of a file into a string * * tcFileName - Name of the file to read * * Returns Character - the contents of a file as a character string. * ****************************************************************************** FUNCTION FileToStr LPARAMETERS tcFileName LOCAL lcReturn, lnBytes * Some bounds checking first IF TYPE('tcFileName') != 'C' OR EMPTY(tcFileName) RETURN '' ENDIF IF FILE(tcFileName) * File exists, open it, and read the contents lnFH = FOPEN(tcFileName) IF lnFH <= 0 * Bad file handle, return an empty string RETURN '' ENDIF ENDIF * Move to the EOF to obtain a byte count lnBytes = FSEEK(lnFH, 0, 2) * Move back to the beginning =FSEEK(lnFH, 0) * Read the contents into a string lcReturn = FREAD(lnFH, lnBytes) =FCLOSE(lnFH) RETURN lcReturn ****************************************************************************** * FUNCTION StrToFile(tcExpression, tcFileName, tlAdditive) * Author: William Kunneke [email protected] * * Writes the contents of a character string to a file. * * tcExpression - Character string to write to the file. * tcFileName - Name of the file * tlAdditive - Specifies if the character string is appended to the end of the * file. If tlAdditive is true (.T.), the character string is appended to the * end of the file. If tlAdditive is false (.F.) (the default), the file is * overwritten with the character string. * * Returns Numeric - number of bytes written to the file. * ****************************************************************************** FUNCTION StrToFile LPARAMETERS tcExpression, tcFileName, tlAdditive LOCAL lnReturn * Some bounds checking first IF TYPE('tcExpression') != 'C' OR TYPE('tcFileName') != 'C' OR ; EMPTY(tcExpression) OR EMPTY(tcFileName) RETURN 0 ENDIF * If tlAdditive was not passed, default to False IF TYPE('tlAdditive') != 'L' tlAdditive = .F. ENDIF IF tlAdditive AND FILE(tcFileName) * File exists, open it, position to the end, and add to it. lnFH = FOPEN(tcFileName, 2) IF lnFH <= 0 RETURN 0 ENDIF =FSEEK(lnFH, 0, 2) ELSE * File does not exist or tlAdditive was set to True lnFH = FCREATE(tcFileName) IF lnFH <= 0 RETURN 0 ENDIF ENDIF lnReturn = FWRITE(lnFH, tcExpression) =FCLOSE(lnFH) RETURN lnReturn #ENDIF *============================================================================= *** End of program. ---- 欢迎光临良友程序库:http://0d0a.126.com http://f12.my163.com,免费提供我的各种Source Code  兄弟我抛出几块砖，有玉的赶紧亮出来啊！ |
|
[关闭][返回] |