Habe es mal mit CustomKeywords erweitert. Mit den Path für die englische Version bin ich mir nicht sicher.
Code: Alles auswählen
EnableExplicit
Structure bptr
b.b[0]
EndStructure
Define.s purebasic_source
Define.s html_output
Define.s source_line
Define.s source_html
Define.s datastring
Define.s tokens
Global NewList keywords.s()
Define.l mode
Enumeration -1
#MODE_ENDOFLINE
#MODE_NORMAL
#MODE_COMMENT
#MODE_STRING
#MODE_CONSTANT
EndEnumeration
Define.l current_position
Define.l character_position
Define.l end_position
Define.s html_dtd = "<!DOCTYPE HTML PUBLIC "+Chr(34)+"-//W3C//DTD HTML 4.01//EN"+Chr(34)+" "+Chr(34)+"http://www.w3.org/TR/html4/strict.dtd"+Chr(34)+">"
Global format_keyword.s, format_comment.s, format_string.s, format_const.s, format_command.s
format_keyword = "<span class="+Chr(34)+"keyword"+Chr(34)+">"
format_comment = "<span class="+Chr(34)+"comment"+Chr(34)+">"
format_string = "<span class="+Chr(34)+"string"+Chr(34)+">"
format_const = "<span class="+Chr(34)+"const"+Chr(34)+">"
format_command = "<span class="+Chr(34)+"command"+Chr(34)+">"
Procedure.l FindMultipleChar(string.s, charstofind.s, startposition.l, mode.l)
Protected current_character.l, number_characters.l, first_position.l, current_position.l, end_pos.l, match.l
Protected direction.w
Protected *string_ptr.bptr, *char_ptr.bptr
first_position = 0
If string<>"" And charstofind<>"" And startposition<=Len(string)
If mode & 1
direction = -1
end_pos = -1
Else
direction = 1
end_pos = Len(string)
EndIf
startposition - 1
If startposition<0
startposition=0
EndIf
*string_ptr = @string
*char_ptr = @charstofind
number_characters = Len(charstofind)
current_position = startposition
While current_position <> end_pos And first_position = 0
match = 0
For current_character=1 To number_characters
If *string_ptr\b[current_position] = *char_ptr\b[current_character-1]
match = -1
EndIf
Next
If mode & 2
match = ~match
EndIf
If match
first_position = current_position + 1
EndIf
current_position + direction
Wend
EndIf
ProcedureReturn first_position
EndProcedure
Procedure.l ChangeMode(token_character.l)
Protected mode.l
Select token_character
Case 34 ; "
mode = #MODE_STRING
Case 35 ; #
mode = #MODE_CONSTANT
Case 59 ; ;
mode = #MODE_COMMENT
Default
mode = #MODE_NORMAL
EndSelect
ProcedureReturn mode
EndProcedure
Procedure.s ReplaceEntities(almost_html.s)
almost_html = ReplaceString(almost_html, Chr(9), " ")
almost_html = ReplaceString(almost_html, "&", "&")
almost_html = ReplaceString(almost_html, "<", "<")
almost_html = ReplaceString(almost_html, ">", ">")
almost_html = ReplaceString(almost_html, Chr(34), """)
ProcedureReturn almost_html
EndProcedure
Procedure.s CheckString(chunk.s)
Protected found.l
If chunk<>""
ResetList(keywords())
While NextElement(keywords()) And found=0
If UCase(chunk)=keywords()
found = 1
chunk = format_keyword + ReplaceEntities(chunk) + "</span>"
EndIf
Wend
EndIf
ProcedureReturn chunk
EndProcedure
Procedure.s GetCss()
Define.s CSS
CSS + "<style type=" + Chr(34) + "text/css" + Chr(34) + ">" + #CRLF$
CSS + "<!--" + #CRLF$
CSS + "BODY { " + #CRLF$
CSS + " font-family: 'Courier New', Courier, mono;" + #CRLF$
CSS + " font-size: 12px;" + #CRLF$
CSS + " color: #000000; " + #CRLF$
CSS + " background-color: #FFFFFF;" + #CRLF$
CSS + "}" + #CRLF$
CSS + ".comment {" + #CRLF$
CSS + " font-family: 'Courier New', Courier, mono;" + #CRLF$
CSS + " font-size: 12px;" + #CRLF$
CSS + " color: #008080;" + #CRLF$
CSS + "}" + #CRLF$
CSS + ".keyword {" + #CRLF$
CSS + " font-family: 'Courier New', Courier, mono;" + #CRLF$
CSS + " font-size: 12px;" + #CRLF$
CSS + " font-weight: bold;" + #CRLF$
CSS + " color: #000099;" + #CRLF$
CSS + "}" + #CRLF$
CSS + ".const {" + #CRLF$
CSS + " font-family: 'Courier New', Courier, mono;" + #CRLF$
CSS + " font-size: 12px;" + #CRLF$
CSS + " color: #990000;" + #CRLF$
CSS + "}" + #CRLF$
CSS + ".string {" + #CRLF$
CSS + " font-family: 'Courier New', Courier, mono;" + #CRLF$
CSS + " font-size: 12px;" + #CRLF$
CSS + " font-style: italic;" + #CRLF$
CSS + " color: #000000;" + #CRLF$
CSS + "}" + #CRLF$
CSS + "-->" + #CRLF$
CSS + "</style>" + #CRLF$
ProcedureReturn CSS
EndProcedure
Procedure PrintWebGadget(URL$)
Define.l ReadyState
Define.IWebBrowser2 WebObject
#OLECMDID_PRINT = 6
#OLECMDEXECOPT_DONTPROMPTUSER = 2
If OpenWindow(0,-16000,0,0,0, "", #PB_Window_SystemMenu)
If CreateGadgetList(WindowID(0))
WebGadget(0,0,0,0,0,URL$)
WebObject = GetWindowLong_(GadgetID(0), #GWL_USERDATA)
Repeat
WebObject\get_ReadyState(@ReadyState)
While WindowEvent() : Wend
Delay(1)
Until ReadyState > 2
If WebObject\ExecWB(#OLECMDID_PRINT, #OLECMDEXECOPT_DONTPROMPTUSER, 0, 0) = #S_OK
SetTimer_(WindowID(0),1,6000,0)
Repeat
Until WaitWindowEvent() = #WM_TIMER And EventwParam() = 1
EndIf
CloseWindow(0)
EndIf
EndIf
EndProcedure
Procedure LoadCustomKeywords(List.s())
Protected path_keywords.s, keyword.s
Protected max, count
path_keywords = GetHomeDirectory() + "Anwendungsdaten\PureBasic\Purebasic.Prefs"
If FileSize(path_keywords) < 0
path_keywords = GetHomeDirectory() + "Applications Data\PureBasic\Purebasic.Prefs"
EndIf
If FileSize(path_keywords) < 0
ProcedureReturn
EndIf
If OpenPreferences(path_keywords)
If PreferenceGroup("CustomKeywords")
max = ReadPreferenceLong("Count", 0)
For count = 1 To max
keyword = ReadPreferenceString("W" + Str(count), "")
If keyword
AddElement(List())
List() = UCase(keyword)
EndIf
Next
EndIf
EndIf
EndProcedure
purebasic_source = ProgramParameter(0)
Define.s drucken
Define.l druckenflag
drucken = ProgramParameter(1)
If UCase(drucken) = "/P"
druckenflag = #True
EndIf
html_output = Left(purebasic_source, Len(purebasic_source) - Len(GetExtensionPart(purebasic_source))) + "html"
If purebasic_source<>"" And html_output<>""
If ReadFile(0, purebasic_source)
If CreateFile(1, html_output)
tokens = " ;#,()=+-*/&|!~<>.$%@?:"+Chr(34)+Chr(9)
Restore Keywords
Repeat
Read datastring.s
If datastring<>""
If AddElement(keywords())
keywords() = UCase(datastring)
Else
MessageRequester("Error", "Failed to created storage for keyword:" + Chr(13) + datastring, #PB_MessageRequester_Ok)
EndIf
EndIf
Until datastring=""
LoadCustomKeywords(keywords())
WriteStringN(1,html_dtd)
WriteStringN(1,"<html>")
WriteStringN(1,"<head>")
WriteStringN(1," <meta name="+Chr(34)+"generator"+Chr(34)+" content="+Chr(34)+"pb2html by David McMinn (some extensions by Thomas Schulz)"+Chr(34)+">")
WriteStringN(1," <title>"+GetFilePart(purebasic_source)+"</title>")
WriteStringN(1, GetCss())
WriteStringN(1,"</head>")
WriteStringN(1,"")
WriteStringN(1,"<body>")
WriteString(1,"<pre class="+Chr(34)+"code"+Chr(34)+">")
While Eof(0)=0
source_line = ReadString(0)
If source_line=""
WriteStringN(1,"")
Else
current_position = 1
mode = #MODE_NORMAL
source_html = ""
While mode<>#MODE_ENDOFLINE
Select mode
Case #MODE_NORMAL
character_position = FindMultipleChar(source_line, tokens, current_position, 0)
If character_position>0
mode = ChangeMode(Asc(Mid(source_line, character_position, 1)))
source_html = source_html + CheckString(Mid(source_line, current_position, character_position - current_position))
If FindMultipleChar(Chr(34)+"#;", Mid(source_line, character_position, 1), 1, 0)<=0
source_html = source_html + ReplaceEntities(Mid(source_line, character_position, 1))
EndIf
current_position = character_position + 1
Else
source_html = source_html + CheckString(Right(source_line, Len(source_line) - current_position + 1))
mode = #MODE_ENDOFLINE
EndIf
Case #MODE_COMMENT
source_html = source_html + format_comment + ReplaceEntities(Right(source_line, Len(source_line) - current_position + 2)) + "</span>"
mode = #MODE_ENDOFLINE
Case #MODE_STRING
end_position = FindString(source_line, Chr(34), current_position)
If end_position=0
end_position = Len(source_line)
mode = #MODE_ENDOFLINE
Else
mode = #MODE_NORMAL
EndIf
source_html = source_html + format_string + ReplaceEntities(Mid(source_line, current_position-1, end_position-current_position+2)) + "</span>"
current_position = end_position + 1
Case #MODE_CONSTANT
end_position = FindMultipleChar(source_line, tokens, current_position, 0)
If end_position=0
end_position = Len(source_line) + 1
mode = #MODE_ENDOFLINE
Else
mode = #MODE_NORMAL
EndIf
source_html = source_html + format_const + ReplaceEntities(Mid(source_line, current_position-1, end_position-current_position+1)) + "</span>"
current_position = end_position
EndSelect
Wend
WriteStringN(1,source_html)
EndIf
Wend
WriteStringN(1,"</pre>")
WriteStringN(1,"</body>")
WriteStringN(1,"</html>")
CloseFile(1)
Else
MessageRequester("Error", "Could not read from source file:"+Chr(13)+purebasic_source, #PB_MessageRequester_Ok)
EndIf
CloseFile(0)
If FileSize(html_output) <> -1
If druckenflag
PrintWebGadget(html_output)
;ShellExecute_(0, "print", html_output, 0, 0, #SW_HIDE)
Else
ShellExecute_(0, "open", html_output, 0, 0, #SW_SHOWNORMAL)
EndIf
EndIf
Else
MessageRequester("Error", "Could not read from source file:"+Chr(10)+purebasic_source, #PB_MessageRequester_Ok)
EndIf
EndIf
End
DataSection ;{
Keywords:
Data.s "And"
Data.s "Break"
Data.s "CallDebugger"
Data.s "Case"
Data.s "CompilerCase"
Data.s "CompilerDefault"
Data.s "CompilerElse"
Data.s "CompilerEndIf"
Data.s "CompilerEndSelect"
Data.s "CompilerIf"
Data.s "CompilerSelect"
Data.s "Continue"
Data.s "Data"
Data.s "DataSection"
Data.s "Debug"
Data.s "DebugLevel"
Data.s "Declare"
Data.s "DeclareCDLL"
Data.s "DeclareDLL"
Data.s "Default"
Data.s "Define"
Data.s "Dim"
Data.s "DisableDebugger"
Data.s "DisableExplicit"
Data.s "Else"
Data.s "ElseIf"
Data.s "EnableDebugger"
Data.s "EnableExplicit"
Data.s "End"
Data.s "EndDataSection"
Data.s "EndEnumeration"
Data.s "EndIf"
Data.s "EndImport"
Data.s "EndInterface"
Data.s "EndProcedure"
Data.s "EndSelect"
Data.s "EndStructure"
Data.s "EndStructureUnion"
Data.s "EndWith"
Data.s "Enumeration"
Data.s "Extends"
Data.s "FakeReturn"
Data.s "For"
Data.s "ForEach"
Data.s "ForEver"
Data.s "Global"
Data.s "Gosub"
Data.s "Goto"
Data.s "If"
Data.s "Import"
Data.s "ImportC"
Data.s "IncludeBinary"
Data.s "IncludeFile"
Data.s "IncludePath"
Data.s "Interface"
Data.s "NewList"
Data.s "Next"
Data.s "OffsetOf"
Data.s "Or"
Data.s "Procedure"
Data.s "ProcedureC"
Data.s "ProcedureCDLL"
Data.s "ProcedureDLL"
Data.s "ProcedureReturn"
Data.s "Protected"
Data.s "Prototype"
Data.s "Read"
Data.s "Repeat"
Data.s "Restore"
Data.s "Return"
Data.s "Select"
Data.s "Shared"
Data.s "SizeOf"
Data.s "Static"
Data.s "Step"
Data.s "Structure"
Data.s "StructureUnion"
Data.s "To"
Data.s "Until"
Data.s "Wend"
Data.s "While"
Data.s "With"
Data.s "XIncludeFile"
Data.s ""
EndDataSection ;}
