 |
||||||||
 |
 |
 |
||||||
| |
|||||||||||||||||||||||||||||||||||||||||||
 |
 | |||
| Ein Programm in der Programmiersprache | A program in the programming language | |||
| Power Basic 10 for Windows | ||||
|
zur Konversion von Power Basic- und Hta-vbScript- Quellcode in HTML-Text
|
for conversion of Power Basic- und Hta-vbScript- Source-Code in HTML-text
| |||
|
Das Programm konvertiert einen einfarbigen Power-Basic Quellcode in einen farbigen HTML-Text. Head- and Body-TAGs sind weg gelassen.
HTML (Hyper Text Markup Langauge) ist eine Seitenbeschreibungssprache und Hta (HTML Application) ist ein HTML-text, nicht zum Hinaufladen zu einem Provider für den weltweiten Zugriff, sondern für den alleinigen Gebrauch auf dem Computer des Benutzers, in welchem ein riesiges Programm in vbScript implementiert sein kann mit demselben Code wie ohne Hta. Aber Hta erzeugt eine Listbox auf dem Bildschirm zur Auswahl von verschiedenen Programmfunktionen. Das Programm funktioniert sowohl zur Konversion von Power-Basic-Source-Code, wie auch von Hta+vbScript-Code zu HTML. Es berücksichtigt Zeilenvorschübe innerhalb von TAGs, korrigiert Groß- und Kleinschreibung von Schlüsselwörtern und konvertiert Sonderzeichen, wie deutsche Umlaute, in HTML-Code. |
The program converts a Power-Basic- or Hta- Source-Code, beeing on hand as a monocolor text, into HTML-text, appropriate to be displayed on screen as colored program-code by recognition of words in the text. Head- and Body-TAGs are ommitted.
HTML (Hyper Text Markup Langauge) is a page-description-language and Hta (HTML Application) is a HTML-text, not for upload to a provider for worldwide access, but for use on the user's computer only, which can have implemented a huge program in vbScript, with the same code as without Hta. But Hta generates a listbox on the screen to select between different program functions. The keywords for the blue and other colors are to type-in in a list under the filename: "Keywords-PB-stm.dat" etc. in the same folder as the script. The program works for conversion of Power-Basic-Source-Code as well as Hta-vbScript-Code to HTML. It considers linefeeds within TAGs, corrects lower-case and upper-case characters in keywords and converts special characters, as also german modified vowels, into HTML-Code. | |||
| Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist | The program ist tested before publication, but there can be given no guarantee, that it is free of errors | |||
| 30. Sept. 2012 | Sept 30th 2012 | |||
|
' ConvertSourceCodeToHTML.bas ' Program in Power Basic 10 for Windows XP and 7 #INCLUDE "Listbox.inc" #INCLUDE "UserOwnModules.inc" ' Arrays GLOBAL ListKeywordsPBstm() AS STRING GLOBAL ListKeywordsPBops() AS STRING GLOBAL ListKeywordsVbsStm() AS STRING GLOBAL ListKeywordsHtaAtt() AS STRING GLOBAL ListText() AS STRING, DisplayText() AS STRING ' Strings GLOBAL Language AS STRING, PrevChar AS STRING, TAG2 AS STRING GLOBAL ColTxt AS STRING, ColKey AS STRING, ColRem AS STRING GLOBAL ColQum AS STRING, ColOps AS STRING, ColFms AS STRING GLOBAL ColAtt AS STRING, ColTag AS STRING, ColNrs AS STRING ' Numerics GLOBAL LineNr AS INTEGER GLOBAL ScriptFlag AS INTEGER, ScriptFlag1 AS INTEGER ' Boolean FUNCTION PBMAIN() DIM sTmp AS STRING sTmp = "Power Basic,HTML-Application,Keyword-Table,InsertCodeInWebsite" REDIM ListBoxItems(1 TO PARSECOUNT(sTmp,",")) PARSE sTmp, ListBoxItems() ListboxTitle = "Convert Source Code to HTML" ' "Dialog1" ListboxLabelText = "Select a Function" ' "Label1" ListboxButtonText = "Start" ' "Button1" ShowDIALOG1 %HWND_DESKTOP ' Select Language Dialog Box END FUNCTION SUB Program(AnyText$) ' AnyText$ = Listbox-Text ' Definitions DIM FileSpecKeywords_PBstm AS STRING DIM FileSpecKeywords_PBops AS STRING DIM FileSpecKeywords_VbsStm AS STRING DIM AllSelectedFilesSpec AS STRING, FileSpecTextIn AS STRING DIM FileSpecTextOut AS STRING, FileSpecTextOutCopy AS STRING DIM sTmp AS STRING, sTmp2 AS STRING, sTmp3 AS STRING, xColor AS STRING DIM CurrentPath AS STRING, CodeLine AS STRING DIM docPath AS STRING, pgmPath AS STRING, keySpec AS STRING DIM CommandLine AS STRING, BrowserSpec AS STRING DIM HTMLtext AS STRING, HTMLtext1 AS STRING DIM TaskNr AS WORD, i AS LONG, j AS LONG, HeadFootFlag AS WORD CALL DeclareModuleVariables ' UserOwnModules activated IF WindowsVersion = "XP" THEN docPath = "c:\Dokumente und Einstellungen\Erich\Eigene Dateien\" pgmPath = "c:\Programme\" ELSEIF WindowsVersion = "7" THEN docPath = "c:\Users\Erich\Documents\" pgmPath = "C:\Program Files\" ELSE MSGBOX "program not forseen for this Windows Version": EXIT SUB END IF FileSpecTextOutCopy = docPath & "html\SourceCode.htm" BrowserSpec = pgmPath & "Internet Explorer\IEXPLORE.EXE" Language = "": TAG2 = "</font>" FOR i = 1 TO UBOUND(ListBoxItems) ' Rename ListBoxItems IF AnyText$ = ListBoxItems(i) THEN Language = PARSE$("PB,hta,table,insert", i) NEXT ' ----------------------- Program -------------------------- DO ' this Do-Loop only runs through once, ' this is made only to can easy exit from algorithm SELECT CASE Language CASE "hta" keySpec = CurrentPath & "Keywords-" LoadFromDisk ListKeywordsVbsStm(), keySpec & ""vbs-stm.dat" IF NOT(ARRAYATTR(ListKeywordsVbsStm(), 0)) THEN EXIT DO AllSelectedFilesSpec = FileOpenSelect(CurrentPath, 1, "*.HTA;*.VBS") IF AllSelectedFilesSpec = "" THEN MSGBOX "no file selected": EXIT DO CASE "PB" keySpec = CurrentPath & "Keywords-" & Language LoadFromDisk ListKeywordsPBstm(), keySpec & "-stm.dat" IF NOT(ARRAYATTR(ListKeywordsPBstm(), 0)) THEN EXIT DO LoadFromDisk ListKeywordsPBops(), keySpec & "-ops.dat" IF NOT(ARRAYATTR(ListKeywordsPBops(), 0)) THEN EXIT DO AllSelectedFilesSpec = FileOpenSelect(CurrentPath, 1, "*.BAS;*.INC") IF AllSelectedFilesSpec = "" THEN MSGBOX "no file selected": EXIT DO CASE "table" AllSelectedFilesSpec = FileOpenSelect(CurrentPath, 1, "*.DAT") IF AllSelectedFilesSpec = "" THEN MSGBOX "no file selected": EXIT DO i = MSGBOX("With Header and Footer ?",%MB_YESNO,"HTML-Table") IF i = %IDYES THEN HeadFootFlag = 1 ELSE HeadFootFlag = 0 CASE "insert" InsertCodeInWebsite: MSGBOX "job done" END SELECT ' One or more files selected FOR TaskNr = 1 TO PARSECOUNT(AllSelectedFilesSpec,CHR$(0))-1 sTmp = AllSelectedFilesSpec sTmp2 = PARSE$(sTmp,CHR$(0),1): sTmp3 =PARSE$(sTmp,CHR$(0),TaskNr+1) FileSpecTextIn = sTmp2 & sTmp3 FileSpecTextOut = sTmp2 & PATHNAME$(NAME, sTmp3) & ".htm" DO ' this Do-Loop only runs through once, ' this is made only to can easy exit from algorithm IF NOT(ISFILE(FileSpecTextIn)) THEN MSG(FileSpecTextIn): EXIT DO ReadArrayFromFile ListText(), FileSpecTextIn IF NOT(ARRAYATTR(ListText(), 0)) THEN MSG(FileSpecTextIn): EXIT DO IF Language = "table" THEN sTmp = RIGHT$(PATHNAME$(NAME, sTmp3),3): xColor = "000000" IF sTmp = "stm" THEN xColor = "0000FF" IF sTmp = "ops" THEN xColor = "8000FF" HTMLtext = MakeTable(ListText(),sTmp3,xColor,4,HeadFootFlag) HTMLtext1 = HTMLtext IF NOT(HeadFootFlag) THEN HTMLtext1 = MakeTable(ListText(),sTmp3,xColor,4,1) END IF REDIM ListText(1 TO PARSECOUNT(HTMLtext,$CRLF)) PARSE HTMLtext,ListText(),$CRLF REDIM DisplayText(1 TO PARSECOUNT(HTMLtext1,$CRLF)) PARSE HTMLtext1,DisplayText(),$CRLF ELSE CALL ConvertTextFromSourceCodeToHTML ' Conversion-Program-Call END IF ' Write Result on disk WriteArrayToFile ListText(), FileSpecTextOut sTmp = PATHNAME$(PATH, FileSpecTextIn) FileSpecTextOutCopy = sTmp & "\SourceCode.htm" WriteArrayToFile ListText(), FileSpecTextOutCopy IF TaskNr 1 THEN EXIT DO ' Display Result in Browser IF Language = "table" THEN sTmp = sTmp2 & "tmp.htm" WriteArrayToFile DisplayText(), sTmp ELSE sTmp = FileSpecTextOut END IF: CommandLine = BrowserSpec & " " & sTmp SHELL(CommandLine): EXIT DO LOOP NEXT: EXIT DO LOOP END SUB ' ----------------------- Procedures --------------------------- SUB ConvertTextFromSourceCodeToHTML DIM htaCode AS STRING, LTxt$, SCR1$, SCR2$ SELECT CASE Language ' Color-Definition CASE "PB" ' ------------------- PB-Code ----------------------- AssignColors FOR LineNr = 1 TO UBOUND(ListText) ConvertCodeLine NEXT CASE "hta" ' ------------------ hta-Code ---------------------- ScriptFlag = ISFALSE 1: htaCode = "" SCR1$ = "<" & "SCRIPT Language=""VBScript""" & ">" SCR2$ = "<" & "/SCRIPT" & ">" FOR LineNr = 1 TO UBOUND(ListText) LTxt$ = ListText(LineNr) IF NOT(ScriptFlag) THEN AssignColors IF INSTR(LTxt$, SCR1$) <> 0 THEN ScriptFlag = ISTRUE 1 ELSE AssignColors IF INSTR(LTxt$, SCR2$) < 0 THEN ScriptFlag = ISFALSE 1 END IF IF NOT(ScriptFlag) THEN IF htaCode < "" THEN htaCode = htaCode & $CRLF htaCode = htaCode & LTxt$ ELSE IF INSTR(LTxt$, SCR1$) < 0 THEN IF htaCode < "" THEN htaCode = htaCode & $CRLF htaCode = htaCode & LTxt$ htaCode = ConvertHtaCode(htaCode) WriteBackHtaText LineNr, htaCode ELSE ConvertCodeLine END IF END IF NEXT htaCode = ConvertHtaCode(htaCode) WriteBackHtaText UBOUND(ListText), htaCode END SELECT ListText(1) = "<font face=""Courier New"" SIZE=""2"">" & ListText(1) ListText(UBOUND(ListText)) = ListText(UBOUND(ListText)) & TAG2 END SUB SUB ConvertCodeLine DIM OldLine AS STRING, NewLine AS STRING, CurCol AS STRING DIM sTmp AS STRING, sTmp2 AS STRING, i AS INTEGER, j AS INTEGER DIM HiLite AS STRING, CurColor AS STRING OldLine = ListText(LineNr): NewLine = "" IF TRIM$(OldLine) = "" THEN ListText(LineNr) = "" ELSE IF UCASE$(LEFT$(TRIM$(OldLine),4)) = "REM " THEN ' RemarkCodeLine NewLine = enTAG(OldLine, ColRem) ELSE ' Word-Recognition IF Language = "PB" THEN sTmp2 = "#PBFORMS,ShowDIALOG" FOR i = 1 TO PARSECOUNT(sTmp2,",") sTmp = PARSE$(sTmp2,",",i) IF LEFT$(OldLine,LEN(sTmp)) = sTmp THEN NewLine = enTAG(OldLine, ColFms) ListText(LineNr) = NewLine: EXIT SUB END IF NEXT END IF: PrevChar = "" DO WHILE LEN(OldLine) ' Char$- and Word-Recognition, Bytewise detect SELECT CASE LEFT$(OldLine, 1) CASE """" ' 1234567i 1i ' "......" "" i = INSTR(2, OldLine, """") IF i = 0 THEN i = LEN(OldLine) sTmp = LEFT$(OldLine,i): sTmp2 = "" IF i > 1 THEN sTmp2 = MID$(sTmp,2,i-2) sTmp2 = ReplaceSpecChars(sTmp2) sTmp = """" & sTmp2 & """" PrevChar = MID$(OldLine,i,1) NewLine = NewLine & enTAG(sTmp, ColQum) OldLine = MID$(OldLine,i+1) CASE "'" sTmp = ReplaceSpecChars(OldLine) NewLine = NewLine & enTAG(sTmp, ColRem) EXIT DO CASE ELSE sTmp2 = RecogniseHiLite(PrevChar, OldLine) IF sTmp2 < "" THEN HiLite = PARSE$(sTmp2,",",1) CurColor = PARSE$(sTmp2,",",2) NewLine = NewLine & enTAG(HiLite, CurColor) OldLine = MID$(OldLine, LEN(HiLite)+1) ELSE sTmp = LEFT$(OldLine,1) i = INSTR($TAB & " <>&äÄöÖüÜߧ", sTmp) IF i > 0 THEN sTmp = ReplaceSpecChars(sTmp) PrevChar = LEFT$(OldLine,1) NewLine = NewLine & sTmp OldLine = MID$(OldLine,2) END IF END SELECT LOOP END IF END IF IF LineNr < UBOUND(ListText) THEN NewLine = NewLine & "<BR>" ListText(LineNr) = NewLine END SUB SUB AssignColors ' If Language = PB then AnyFlag irrelevant ColTxt = "000000": ColRem = "007F00" SELECT CASE Language CASE "PB" ColKey = "0000C0": ColOps = "8000FF" ' Keywords and Operators ColFms = "C06400": ColQum = "C020C0" ' Forms and Quotation marks CASE "hta" ColKey = "0000FF": ColNrs = "A52A2A" ' Keywords and Numbers ColTag = "A52A2A": ColAtt = "FF0000" ' Tagnames and Attributes IF NOT(ScriptFlag) THEN ColQum = "408080" ELSE ColQum = "808080" END SELECT END SUB SUB LoadFromDisk(BYREF AnyList() AS STRING, AnyFileSpec AS STRING) DIM AnyList() AS STRING IF NOT(ISFILE(AnyFileSpec)) THEN MSG(AnyFileSpec): EXIT SUB ReadArrayFromFile AnyList(), AnyFileSpec IF NOT(ARRAYATTR(AnyList(), 0)) THEN MSG(AnyFileSpec): EXIT SUB WriteArrayToFile AnyList(), AnyFileSpec & ".bak" ARRAY SORT AnyList(), COLLATE UCASE, ASCEND RemoveDoubleItems AnyList() WriteArrayToFile AnyList(), AnyFileSpec SortForWordLenght AnyList() END SUB SUB MSG(AnyFileSpec AS STRING) DIM MsgTmp$: MsgTmp$ = AnyFileSpec IF MID$(AnyFileSpec,2,2) = ":\" THEN MsgTmp$ = "file """ & MID$(AnyFileSpec,_ INSTR(-1, AnyFileSpec,"\")+1) & """ missing" END IF: MSGBOX MsgTmp$,,"Error" END SUB SUB SortForWordLenght(BYREF AnyArray() AS STRING) DIM sTmp AS STRING, i AS LONG, Flag AS INTEGER: Flag = ISTRUE 1 WHILE Flag Flag = ISFALSE 1 FOR i = 1 TO UBOUND(AnyArray)-1 IF LEN(AnyArray(i)) < LEN(AnyArray(i+1)) THEN sTmp = AnyArray(i): AnyArray(i) = AnyArray(i+1) AnyArray(i+1) = sTmp: Flag = ISTRUE 1 END IF NEXT WEND END SUB FUNCTION ConvertHtaCode(AnyCode AS STRING) AS STRING ' Converts chain of multiple lines DIM TAGdyed AS STRING, sTmp AS STRING, j AS INTEGER, k AS INTEGER TAGdyed = "" DO WHILE LEN(AnyCode): j = INSTR(AnyCode,"<"): k = INSTR(AnyCode,">") IF j = 0 OR k = 0 OR j > k THEN sTmp = AnyCode REPLACE "<" WITH "<" IN sTmp REPLACE ">" WITH ">" IN sTmp TAGdyed = enTAG(sTmp, ColTxt): EXIT DO ELSE TAGdyed = TAGdyed & DyeTAG(LEFT$(AnyCode,k)) AnyCode = MID$(AnyCode,k+1) END IF LOOP: ConvertHtaCode = TAGdyed END FUNCTION FUNCTION DyeTAG(AnyString AS STRING) AS STRING ' One TAG ' "....<..." "....>..." "....>...<..." "....<...>..." DIM TAG AS STRING, TAGtxt AS STRING, TAGname AS STRING, TAGattr AS STRING DIM TAGdyed AS STRING, sTmp AS STRING, sTmp2 AS STRING DIM i AS INTEGER, j AS INTEGER, k AS INTEGER TAG = "": TAGtxt = "": TAGname = "": TAGattr = "": TAGdyed = "" IF LEN(AnyString) THEN j = INSTR(AnyString,"<"): k = INSTR(AnyString,">") IF j > 1 THEN TAGdyed = LEFT$(AnyString, j-1) REPLACE " " WITH " " IN TAGdyed AnyString = MID$(AnyString,j): j = 1: k = INSTR(AnyString,">") END IF: TAG = LEFT$(AnyString,k) IF TAG < "" THEN i = INSTR(TAG," "): IF i = 0 THEN i = LEN(TAG) TAGname = MID$(TAG,2,i-2): TAGattr = MID$(TAG, i, LEN(TAG) - i) IF MID$(TAG,2,3) = "!--" THEN TAGdyed = TAGdyed & enTAG("<" & TAGname & _ TAGattr & ">", ColRem) ELSE TAGdyed = TAGdyed & enTAG("<",ColKey) & enTAG(TAGname,ColTag) ' Dye Attributes for example size="3" name="mylistbox" IF LEN(TAGattr) THEN sTmp2 = "": i = 1 DO j = INSTR(i, TAGattr,"="): IF j = 0 THEN EXIT DO sTmp = MID$(TAGattr,i,j-i) REPLACE $TAB WITH " " IN sTmp REPLACE " " WITH " " IN sTmp sTmp2 = sTmp2 & enTAG(sTmp,ColAtt) i = j: j = INSTR(j,TAGattr,""""): IF j = 0 THEN EXIT DO j = INSTR(j+1,TAGattr,""""): IF j = 0 THEN EXIT DO sTmp2 = sTmp2 & enTAG(MID$(TAGattr,i,j-i+1),ColQum) i = j + 1 LOOP END IF: TAGdyed = TAGdyed & sTmp2 & enTAG(">",ColKey) END IF END IF END IF: DyeTAG = TAGdyed END FUNCTION SUB WriteBackHtaText(AnyLineNr AS INTEGER, BYREF AnyCode AS STRING) DIM i AS INTEGER, j AS INTEGER, pcount AS INTEGER pcount = PARSECOUNT(AnyCode,$CRLF) FOR i = 1 TO pcount j = AnyLineNr + i - pcount ListText(j) = PARSE$(AnyCode,$CRLF,i) IF j < UBOUND(ListText) THEN ListText(j) = ListText(j) & "<BR>" NEXT: AnyCode = "" END SUB FUNCTION ReplaceSpecChars(AnyString AS STRING) AS STRING DIM SpecChars AS STRING, Char AS STRING, Chars AS STRING DIM i AS INTEGER, j AS INTEGER, sTmp AS STRING : sTmp = "" ' insert HTML-code for special characters ' && must be on first place ' at the end ";" must be missing REPLACE $TAB WITH " " IN AnyString Chars = "&äÄöÖüÜß ""<>§" SpecChars = "&äÄöÖü" & _ "Üß "<>§" FOR i = 1 TO LEN(AnyString) Char = MID$(AnyString,i,1): j = INSTR(Chars,Char) IF j > 0 THEN Char = PARSE$(SpecChars,";",j) & ";" sTmp = sTmp & Char NEXT: ReplaceSpecChars = sTmp END FUNCTION FUNCTION RecogniseHiLite(AnyPrevChar AS STRING, AnyString AS STRING) AS STRING LOCAL KeyWord AS STRING, CurColor AS STRING LOCAL j AS WORD, sTmp AS STRING: FUNCTION = "" SELECT CASE Language CASE "PB" KeyWord = RecogniseWord(AnyPrevChar, AnyString, ListKeywordsPBstm(), 3) IF KeyWord < "" THEN ' Exceptions sTmp = "%IDC_,%IDD_" FOR j = 1 TO PARSECOUNT(sTmp) IF UCASE$(KeyWord) = UCASE$(PARSE$(sTmp,",",j)) THEN CurColor = ColTxt: EXIT SELECT END IF NEXT: CurColor = ColKey: EXIT SELECT END IF KeyWord = RecogniseWord(AnyPrevChar, AnyString, ListKeywordsPBops(), 3) IF KeyWord < "" THEN CurColor = ColOps CASE "hta" KeyWord = IsNr(AnyPrevChar, AnyString) IF KeyWord < "" THEN CurColor = ColNrs: EXIT SELECT KeyWord = RecogniseWord(AnyPrevChar, AnyString, ListKeywordsVbsStm(), 2) IF KeyWord < "" THEN CurColor = ColOps END SELECT: IF KeyWord < "" THEN FUNCTION = KeyWord & "," & CurColor END FUNCTION FUNCTION IsNr(AnyPrevChar AS STRING, AnyString AS STRING) AS STRING DIM sTmp$, Chrs$, C0$, C$, C1$, i AS INTEGER, Number AS INTEGER C0$ = AnyPrevChar: Number = ISTRUE 1: IsNr = "" Chrs$ = $TAB & " .,;+-*\/()=<>" DO IF NOT(InStrAny(C0$, ",", Chrs$)) THEN EXIT DO FOR i = 1 TO LEN(AnyString) sTmp$ = MID$(AnyString,i,2): C$ = LEFT$(sTmp$,1) IF NOT(InStrAny(C$, "0-9", ".")) THEN Number = ISFALSE 1: EXIT FOR NEXT: i = i - 1: IF Number THEN i = LEN(AnyString) C1$ = MID$(AnyString,i+1,1) IF NOT(InStrAny(C1$, ",", Chrs$)) THEN EXIT DO IsNr = LEFT$(AnyString,i): EXIT DO LOOP END FUNCTION FUNCTION RecogniseWord(AnyPrevChar AS STRING, AnyString AS STRING, _ AnyListOfKeyWords() AS STRING, AnyMode AS WORD) AS STRING ' Mode: 0 = charsize of AnyString, 1 = Charsize of AnyWord, 2 = Charsize UCase(AnyWord) DIM i AS WORD, L AS WORD, Ubd AS WORD: Ubd = UBOUND(AnyListOfKeyWords) DIM sTmp AS STRING, sTmp1 AS STRING, sTmp2 AS STRING DIM KeyWord AS STRING: FUNCTION = "" sTmp1 = "A-z,0-9" & $LF & "!""§$%#_": sTmp2 = "A-z,0-9" & $LF & "§$.äöüÄÖÜß_" IF ISFALSE (AnyMode AND 3) THEN EXIT FUNCTION IF AnyString = "" THEN EXIT FUNCTION FOR i = 1 TO Ubd ' KeywordArray KeyWord = AnyListOfKeyWords(i): L = LEN(KeyWord) IF L <= LEN(AnyString) THEN IF UCASE$(LEFT$(AnyString,L)) = UCASE$(LEFT$(KeyWord,L)) THEN sTmp = LEFT$(KeyWord,1) IF INSTR("()",sTmp) = 0 THEN ' all brackets violet in PB IF InStrAny(AnyPrevChar, PARSE$(sTmp1,$LF,1), _ PARSE$(sTmp1,$LF,2)) THEN EXIT FUNCTION END IF ' CharSize sTmp = LEFT$(AnyString,L) & "," & LEFT$(KeyWord,L) _ & "," & UCASE$(LEFT$(KeyWord,L)) FUNCTION = PARSE$(sTmp, ",", AnyMode) IF L < LEN(AnyString) THEN sTmp = LEFT$(KeyWord,1) IF INSTR("()",sTmp) = 0 THEN ' all brackets violet in PB IF InStrAny(MID$(AnyString,L+1,1), PARSE$(sTmp2,$LF,1), _ PARSE$(sTmp2,$LF,2)) THEN FUNCTION = "" END IF END IF: EXIT FUNCTION END IF END IF NEXT END FUNCTION FUNCTION MakeTable(AnyList() AS STRING, AnyTitle AS STRING, AnyColor AS STRING, _ NrCol AS WORD, HeadAndFoot AS INTEGER) AS STRING LOCAL Head AS STRING, TableTxt AS STRING, Foot AS STRING LOCAL LineTxt AS STRING, sTmp AS STRING, sTmp2 AS STRING LOCAL sp AS STRING, sp1 AS STRING LOCAL TM AS STRING ' Top Margin LOCAL BM AS STRING ' Bottom Margin LOCAL LM AS STRING ' Left Margin LOCAL RM AS STRING ' Right Margin LOCAL Ubd AS WORD, rw AS WORD, clm AS WORD, ListPos AS WORD LOCAL HeaderAndFooter AS INTEGER ' used as flag TM = "40": BM = "40": LM = "40": RM = "40" HeaderAndFooter = ISTRUE HeadAndFoot sp = TRIM$(STR$(2*NrCol)): sp1 = TRIM$(STR$(2*NrCol+1)) Head = "": Foot = "" IF HeaderAndFooter THEN Head = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"" " & _ """http://www.w3.org/TR/html4/loose.dtd"">" & $CRLF & _ "<html><head><title>Tablemaking</title>" & $CRLF & _ "<meta NAME=""author"" CONTENT=""Erich"">" & $CRLF & _ "<meta NAME=""editor"" CONTENT=""html-editor phase 5"">" & _ "</head>" & $CRLF & _ "<body text=""#000000"" bgcolor=""#DDDDDD"" link=""#FF0000"" " & _ "alink=""#FF0000"" vlink=""#FF0000"">" & $CRLF Foot = "</body></html> " END IF TableTxt = $CRLF & "<span style=""font-family:Courier New;font-size:10pt;color:#" & _ AnyColor & ";"">" & $CRLF & _ "<table border=""0"" cellpadding=""0"" cellspacing=""0"" " & _ "align=""center"" bgcolor=""#FFFFFF"">" & $CRLF & _ "<tr><td colspan=""" & sp1 & """ height=""" & TM & """></tr>" & $CRLF & _ "<tr><td><td colspan=""" & sp & """><B>" & AnyTitle & _ "</B><BR><BR></td></tr>" Ubd = UBOUND(AnyList) FOR rw = 0 TO INT((Ubd)/NrCol)-1 sTmp = "<td>": sTmp2 = "<td>" IF rw = 0 THEN sTmp = "<td width=""120"">": sTmp2 = "<td width=""" & RM & """>" END IF: LineTxt = "" FOR clm = 0 TO NrCol-1 ListPos= clm*INT((Ubd-1)/NrCol) + rw + 1 LineTxt = LineTxt & $CRLF & sTmp & AnyList(ListPos) & _ "</td>" & sTmp2 & "</td>" NEXT sTmp = "<td>": IF rw = 0 THEN sTmp = "<td width=""" & LM & """>" LineTxt = sTmp & LineTxt & "</td>" TableTxt = TableTxt & $CRLF & "<tr>" & LineTxt & "</tr>" NEXT TableTxt = TableTxt & "<tr><td height=""" & BM & " colspan=""" & sp1 & _ """></tr>" & $CRLF & "</table></span>" & $CRLF & $CRLF FUNCTION = Head & TableTxt & Foot END FUNCTION SUB InsertCodeInWebsite LOCAL FileSpec1 AS STRING, FileSpec2 AS STRING, FileSpecBak AS STRING LOCAL HTMLText1 AS STRING, HTMLText2 AS STRING LOCAL TxtMark1 AS STRING, TxtMark2 AS STRING LOCAL StartPath AS STRING LOCAL sTmp AS STRING, i AS LONG, j AS LONG ' Definitions StartPath = "d:\WebsitePath\" TxtMark1 = "<!-- Beginn des Tabelleninhaltes -->" TxtMark2 = "<!-- Ende des Tabelleninhaltes -->" ' Program IF NOT(ISFOLDER(StartPath)) THEN MSGBOX "Homepagefolder does not exist": EXIT SUB sTmp = FileOpenSelect(CurrentPath, 0, "*.HTM;*.HTML") IF sTmp = "" THEN MSGBOX "no file selected": EXIT SUB FileSpec1 = PARSE$(sTmp,CHR$(0),1) & PARSE$(sTmp,CHR$(0),2) sTmp = FileOpenSelect(StartPath, 0, "*.HTM;*.HTML") IF sTmp = "" THEN MSGBOX "no file selected": EXIT SUB FileSpec2 = PARSE$(sTmp,CHR$(0),1) & PARSE$(sTmp,CHR$(0),2) ReadTextFromFile HTMLText1, FileSpec1 ReadTextFromFile HTMLText2, FileSpec2 ' make a bak-file of website FileSpecBak = PATHNAME$(PATH, FileSpec2) & PATHNAME$(NAME, FileSpec2) & _ "-bak" & PATHNAME$(EXTN, FileSpec2) WriteTextToFile HTMLText2, FileSpecBak ' find markers and insert code i = INSTR(HTMLText2, TxtMark1): sTmp = "anything wrong with textmark" IF i = 0 THEN MSGBOX sTmp: EXIT SUB i = i + LEN(TxtMark1)- 1: j = INSTR(i + 1, HTMLText2, TxtMark2) IF j = 0 OR j <= i THEN MSGBOX sTmp: EXIT SUB HTMLText2 = LEFT$(HTMLText2,i) & $CRLF & "<BR>" & _ HTMLText1 & "<BR>" & $CRLF & MID$(HTMLText2,j) WriteTextToFile HTMLText2, FileSpec2 END SUB | ||
Keyword- and Operators-Tables on website: TableMaking.html
The preliminary complete documentation on this PDF: ConvertSourceCodeToHTML.pdf