Bon... J'ai un peu fait dans la colle mais déjà, ça simplifie le problème en cas de conversion.
C'est un simple visualisateur de code source fait grâce au RTF dans l'EditorGadget ss Windows. Ce n'est pas grandiose, mais bon...
Code : Tout sélectionner
;{ Suppl�ment }
;- Window
Procedure WindowSize(Window, *W.INTEGER, *H.INTEGER)
*W\I = WindowWidth(Window)
*H\I = WindowHeight(Window)
EndProcedure
;- Compiler options
Global CompilerProgram.I
Global CompilerMessage.S
Global CompilerBasicFile.S
Global CompilerFunctionQuantity.I
Procedure.S CompilerRead()
CompilerMessage = ReadProgramString(CompilerProgram)
ProcedureReturn CompilerMessage
EndProcedure
Procedure.I CompilerWrite(Message.S)
ProcedureReturn WriteProgramStringN(CompilerProgram, Message)
EndProcedure
Procedure.I CompilerOpen()
CompilerProgram = RunProgram("PbCompiler.EXE", "/STANDBY", #PB_Compiler_Home + "\Compilers", #PB_Program_Open | #PB_Program_Read | #PB_Program_Write | #PB_Program_Hide)
CompilerRead()
CompilerRead()
EndProcedure
Procedure.I CompilerClose()
CompilerWrite("END")
EndProcedure
Procedure.I CompilerFunctionListLoad(*RtSetKeyword, Color.I, Alinea.I, KeywordType.I)
Protected Result, n, Message.S, FunctionName.S
CompilerOpen()
If CompilerProgram
CompilerWrite("FUNCTIONLIST")
CompilerFunctionQuantity = Val(CompilerRead() )
n = 0
Repeat
Message = CompilerRead()
n + 1
FunctionName = StringField(Message, 1, " ")
CallFunctionFast(*RtSetKeyword, @FunctionName, Color, Alinea, KeywordType)
Until Message = "OUTPUT" + Chr(9) + "COMPLETE"
If n = CompilerFunctionQuantity + 1
Result = 1
EndIf
CompilerClose()
EndIf
ProcedureReturn Result
EndProcedure
;- Rich text String
Procedure.S Rich(Text.S) ; merci Octavius
fonte0$ = "{\fonttbl{\f0\fswiss\fprq2\fcharset0 Tahoma;}" ; d�sign� par \f0
fonte1$ = "{\f1\fswiss\fcharset0 Arial;}" ; d�sign� par \f1
fonte2$ = "{\f2\fcharset0 Courier;}}" ; d�sign� par \f2
table_couleur$ = "{\colortbl ;\red0\green0\blue127;\red0\green127\blue0;\red0\green127\blue127;"
table_couleur$ + "\red127\green0\blue0;\red127\green0\blue127;\red191\green127\blue0;\red127\green127\blue127;"
table_couleur$ + "\red63\green63\blue63;\red0\green0\blue255;\red0\green255\blue0;\red0\green255\blue255;"
table_couleur$ + "\red255\green0\blue0;\red255\green0\blue255;\red255\green255\blue0;\red255\green255\blue255;}"
langue$ = "{\deflang1036}"
ProcedureReturn "{\rtf1\ansi " + langue$ + table_couleur$ + fonte0$ + fonte1$ + fonte2$ + Text + "}"
EndProcedure
Procedure.S RichChar(IT.S, Chars.S)
CharsQuantity = Len(Chars)
For I = 1 To CharsQuantity
A.S = Mid(Chars, I, 1)
IT = ReplaceString(IT, A, "\'" + LCase(Hex(Asc(A) ) ) )
Next
ProcedureReturn IT
EndProcedure
Procedure.S RichText(IT.S, Prefix.S)
ProcedureReturn "{\" + Prefix + " " + IT + "}"
EndProcedure
Procedure.S RtBold(IT.S)
ProcedureReturn RichText(IT, "b")
EndProcedure
Procedure.S RtCourier(IT.S)
ProcedureReturn RichText(IT, "f2")
EndProcedure
Procedure.S RtArial(IT.S)
ProcedureReturn RichText(IT, "f1")
EndProcedure
;- Structure RtKeyword
Structure RtKeyword
CasedName.S ; Mot-clef avec casse
Color.I
Alinea.I ; 0 : Indiff�rent
; 1 : Dresse la ligne suivante
; 2 : Baisse imm�diate
; 3 : Baisse imm�diate et dresse la ligne suivante
; 4 : Double l'effet (pour 'Select' & 'EndSelect')
Type.I
EndStructure
Global NewMap RtKey.RtKeyword()
Global Alinea, NextAlinea
Global ProcedureStep
Global ProcedureOutType
Global ProcedureColor = 12
Global ProcedureName.S
#BasicKeyword = 1
#ProcNameKeyword = 2
#FunctionKeyword = 4
Procedure RtSetKeyword(Name.S, Color.I, Alinea.I, KeywordType.I)
With RtKey(UCase(Name) )
\CasedName = Name
\Color = Color
\Alinea = Alinea
\Type = KeywordType
EndWith
EndProcedure
Procedure RtInit()
RtSetKeyword("Procedure", 2, 1, #BasicKeyword)
RtSetKeyword("EndProcedure", 2, 2, #BasicKeyword)
RtSetKeyword("ProcedureReturn", 2, 0, #BasicKeyword)
RtSetKeyword("With", 2, 1, #BasicKeyword)
RtSetKeyword("EndWith", 2, 2, #BasicKeyword)
RtSetKeyword("Structure", 1, 1, #BasicKeyword)
RtSetKeyword("EndStructure", 1, 2, #BasicKeyword)
RtSetKeyword("Select", 9, 5, #BasicKeyword)
RtSetKeyword("EndSelect", 9, 6, #BasicKeyword)
RtSetKeyword("Case", 9, 3, #BasicKeyword)
RtSetKeyword("If", 9, 1, #BasicKeyword)
RtSetKeyword("Else", 9, 3, #BasicKeyword)
RtSetKeyword("EndIf", 9, 2, #BasicKeyword)
RtSetKeyword("Protected", 3, 0, #BasicKeyword)
RtSetKeyword("Define", 3, 0, #BasicKeyword)
RtSetKeyword("Global", 3, 0, #BasicKeyword)
RtSetKeyword("Shared", 3, 0, #BasicKeyword)
RtSetKeyword("Static", 3, 0, #BasicKeyword)
RtSetKeyword("Repeat", 13, 1, #BasicKeyword)
RtSetKeyword("Until", 13, 2, #BasicKeyword)
RtSetKeyword("For", 13, 1, #BasicKeyword)
RtSetKeyword("Next", 13, 2, #BasicKeyword)
RtSetKeyword("While", 13, 1, #BasicKeyword)
RtSetKeyword("Wend", 13, 1, #BasicKeyword)
CompilerFunctionListLoad(@RtSetKeyword(), 6, 0, #FunctionKeyword)
EndProcedure
RtInit()
Procedure.S RtKeyword(IT.S) ; (Input Text String)
Protected Key.S
Protected Effect = 1
Key = UCase(IT)
If ProcedureStep = 2 ; le point '.' de type de sortie de proc�dure a �t� d�tect� pr�alablement
ProcedureOutType = Asc(Key)
ProcedureStep = 3 ; en attente de l'identification du nom de la proc�dure...
ProcedureReturn IT
EndIf
Debug Key
If FindMapElement(RtKey(), Key) ; Mot-clef identifi�?
; 1.Marges
If RtKey(Key)\Alinea & 4
Effect * 2
EndIf
If RtKey(Key)\Alinea & 2
Alinea - Effect
NextAlinea = Alinea
EndIf
If RtKey(Key)\Alinea & 1
NextAlinea = Alinea + Effect
EndIf
IT = RichText(RtKey(Key)\CasedName, "cf" + Str(RtKey(Key)\Color) )
; 2.Analyses
If Key = "PROCEDURE"
ProcedureStep = 1 ; en attente du typage de sortie de proc�dure...
EndIf
Else
If ProcedureStep = 1 ; si le point '.' de type de sortie de proc�dure non d�tect�
ProcedureOutType = Asc("I") ; alors c'est un entier
ProcedureStep = 3 ; en attente de l'identification du nom de la proc�dure...
EndIf
If ProcedureStep = 3 ; Identification du nom de la proc�dure
RtSetKeyword(IT, ProcedureColor, 0, #ProcNameKeyword)
ProcedureName = IT
IT = RichText(RtKey(Key)\CasedName, "cf" + Str(RtKey(Key)\Color) )
ProcedureStep = 0
EndIf
EndIf
ProcedureReturn RtCourier(RtBold(IT) )
EndProcedure
Procedure.S RtAlinea()
Protected OT.S
For I = 1 To Alinea
OT + Chr(9)
Next
ProcedureReturn OT
EndProcedure
;- Text
Procedure LoadText(FileName.S, *Text.STRING)
Protected Size
Protected TextFile
Size = FileSize(FileName)
If Size > -1
TextFile = OpenFile(#PB_Any, FileName, #PB_File_SharedRead)
If TextFile
*Text\S = ReadString(TextFile, #PB_File_IgnoreEOL, Size)
CloseFile(TextFile)
EndIf
EndIf
EndProcedure
Procedure SaveText(FileName.S, *Text.STRING)
Protected TextFile
TextFile = CreateFile(#PB_Any, FileName)
If TextFile
WriteString(TextFile, *Text\S)
CloseFile(TextFile)
EndIf
EndProcedure
Procedure PaintText(TreeID, TextID, *Text.STRING, Item = -16)
Protected EnableLineFeed = 1
Protected Keyword.S
Protected IT.S ; Input Text
Protected CT.S ; Current Text
Protected OT.S ; Output Text
Protected LineBegin = 1
If Item = -16
IT = UCase(*Text\S)
LIT = Len(IT)
For I = 1 To LIT
A = Asc(Mid(IT, I, 1) )
If LineBegin
If A > 32
LineBegin = 0
EndIf
If A = 13
CT = "\par "
Alinea = NextAlinea
LineBegin = 1
OT + CT
CT = ""
EndIf
EndIf
If LineBegin = 0
If A = 34
Inext = FindString(IT, Chr(34), I + 1)
CT + Chr(34) + RtArial(RichChar(Mid(*Text\S, I + 1, Inext - I - 1), "\{}") ) + Chr(34)
I = Inext
Else
If A = Asc(";")
If Mid(*Text\S, I + 1, 5) = " IDE "
Break
EndIf
Inext = FindString(IT, Chr(13), I)
If Inext = 0 ; Pas de retour de ligne...
Inext = LIT ; ... Donc fin de listing
EndIf
Inext - 1
CT + ";" + RtBold(RtArial(RichChar(Mid(*Text\S, I + 1, Inext - I), "\{}") ) )
I = Inext
Else
A0 = Asc(Mid(*Text\S, I, 1) ) ; R�cup�re la vraie casse
If (A => 65 And A <= 90) Or (A => 48 And A <= 57) Or (A = 95) Or (A > 127) ; Nom de variable?
If Expr = 0
Expr = 1
Keyword = Chr(A0)
Else
Keyword + Chr(A0)
EndIf
Else ; Pas Nom de variable?
If Expr = 1 ; Mais on vient de terminer la lecture d'un nom de variable?
Expr = 0
CT + RtKeyword(Keyword)
EndIf
If (A > 31) Or (A = 9)
If ProcedureStep = 1
;Debug "->" + Chr(A)
If A = Asc(".")
ProcedureStep = 2
; End
EndIf
EndIf
CT + RichChar(Chr(Asc(Mid(*Text\S, I, 1) ) ), "\{}")
Else
Select A
Case 13
CT = RtAlinea() + CT + "\par "
Alinea = NextAlinea
LineBegin = 1
OT + CT
CT = ""
EndSelect
EndIf
EndIf
EndIf
EndIf
EndIf
If ProcedureName
AddGadgetItem(TreeID, -1, ProcedureName, 0, Alinea)
ProcedureName = ""
EndIf
Next
SetGadgetText(TextID, Rich(OT) )
Else
;SetGadgetItemText(TextID, Item, Rich(Text) )
EndIf
EndProcedure
;}
WinW = 600
WinH = 300
WinFlag = #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget
TreW = 200
Define Text.STRING
Define Line.STRING
Define FileName.S = #PB_Compiler_File
WinID = OpenWindow(#PB_Any, 0, 0, WinW, WinH, FileName, WinFlag)
TreID = TreeGadget(#PB_Any, 0, 0, TreW, WinH)
EdiID = EditorGadget(#PB_Any, TreW, 0, WinW - TreW, WinH)
St0ID = SplitterGadget(#PB_Any, 0, 0, WinW, WinH, TreID, EdiID, #PB_Splitter_Vertical | #PB_Splitter_FirstFixed)
SetActiveGadget(EdiID)
LoadText(FileName, Text)
PaintText(TreID, EdiID, Text)
Repeat
WinEv = WaitWindowEvent()
If WinEv = #PB_Event_SizeWindow
WindowSize(WinID, @WinW, @WinH)
ResizeGadget(St0ID, 0, 0, WinW, WinH)
EndIf
Until WinEv = #PB_Event_CloseWindow
Text\S = GetGadgetText(EdiID)
;SaveText(FileName, Text)
CloseWindow(WinID)