XProfan

PRFellow-Présentation
Autor: Thomas Bois - Alle Rechte vorbehalten
Beispiel-Programme pour une fenstergebundene Console
Requiert Profan 6.1 à cause de Addr-Funktion
(Commutateur sur Profan 5.0 avec Bereichsvariable ist possible)
(c) 2000 Thomas Bois, Siegen - Alle Rechte vorbehalten
Def AllocConsole(0) !KERNEL32,AllocConsole
Def CloseHandle(1) !KERNEL32,CloseHandle
Def CreateConsoleScreenBuffer(5) !KERNEL32,CreateConsoleScreenBuffer
Def FillConsoleOutputAttribute(5) !KERNEL32,FillConsoleOutputAttribute
Def FlushConsoleInputBuffer(1) !KERNEL32,FlushConsoleInputBuffer
Def FreeConsole(0) !KERNEL32,FreeConsole
Def GetConsoleTitle(2) !KERNEL32,GetConsoleTitleA
Def GetConsoleScreenBufferInfo(2) !KERNEL32,GetConsoleScreenBufferInfo
Def GetStdHandle(1) !KERNEL32,GetStdHandle
Def ReadConsole(5) !KERNEL32,ReadConsoleA
Def ReadConsoleOutputCharacter(5) !KERNEL32,ReadConsoleOutputCharacterA
Def ReadFile(5) !KERNEL32,ReadFile
Def SetConsoleActiveScreenBuffer(1) !KERNEL32,SetConsoleActiveScreenBuffer
Def SetConsoleCursorPosition(2) !KERNEL32,SetConsoleCursorPosition
Def SetConsoleMode(2) !KERNEL32,SetConsoleMode
Def SetConsoleTextAttribute(2) !KERNEL32,SetConsoleTextAttribute
Def SetConsoleTitle(1) !KERNEL32,SetConsoleTitleA
Def WriteConsole(5) !KERNEL32,WriteConsoleA
Def WriteConsoleOutputCharacter(5) !KERNEL32,WriteConsoleOutputCharacterA
Def WriteFile(5) !KERNEL32,WriteFile
Def OemToCharBuff(3) !USER32,OemToCharBuffA
Def CharToOemBuff(3) !USER32,CharToOemBuffA
Def FillMemory(3) !KERNEL32,RtlFillMemory
Def ZeroMemory(2) !KERNEL32,RtlZeroMemory
Def ExitProcess(1) !KERNEL32,ExitProcess
Def MakeLong(2) Or(&(1),Mul(&(2),$10000))
Def HiWord(1) Div&(&(1),$10000)
Def LoWord(1) And(&(1),$FFFF)
Def GetInput(0) $(0)
Def GetCleanInput(0) Upper$(Trim$($(0)))
Def RemoveCR(1) Translate$($(1),Ajouter$(Chr$(13),Chr$(10)),Chr$(32))
Déclarer hinput&,houtput&,herror&,hscrbuf&
Déclarer BUF_INFO#,c_buf#
Déclarer INPUT_REC#

Proc GetScreenBufSize

    Déclarer size&
    Faible BUF_INFO#,20
    GetConsoleScreenBufferInfo(hscrbuf&,BUF_INFO#)
    Laisser size&=Long(BUF_INFO#,0)
    Laisser size&=Mul(LoWord(size&),HiWord(size&))  chez WideChar * 2, mais wir prendre ANSI
    Dispose BUF_INFO#
    Retour size&

ENDPROC

Proc LineColor

    Paramètres fg%,bg%
    Déclarer colattr&
    Laisser colattr&=Or(fg%,Mul(bg%,4))
    SetConsoleTextAttribute(hscrbuf&,colattr&)

ENDPROC

Proc _WriteLn

    Paramètres txt$,oem_convert%,cr%
    Déclarer written&
    Laisser txt$=txt$
    Cas cr%: Laisser txt$=txt$;Chr$(13);Chr$(10)
    Faible c_buf#,Ajouter(Len(txt$),1)
    String c_buf#,0=txt$
    Cas oem_convert%: CharToOemBuff(c_buf#,c_buf#,Len(txt$))
    WriteConsole(hscrbuf&,c_buf#,Len(txt$),Addr(written&),0)
    WriteFile(hscrbuf&,c_buf#,Len(txt$),Addr(written&),0)
    Dispose c_buf#

ENDPROC

Proc Write

    Paramètres txt$
    _Writeln txt$,1,0

ENDPROC

Proc WriteCR

    _Writeln ,0,1

ENDPROC

Proc WriteLn

    Déclarer txt$,i%
    Laisser i%=1

    WhileNot Gt(i%,%pcount)

        Laisser txt$=Ajouter$(txt$,$(i%))
        Inc i%

    Wend

    _Writeln txt$,1,1

ENDPROC

Proc WriteCGI

    Paramètres txt$
    _Writeln txt,0,0

ENDPROC

Proc WriteLnCGI

    Déclarer txt$,i%
    Laisser i%=1

    WhileNot Gt(i%,%pcount)

        Laisser txt$=Ajouter$(txt$,$(i%))
        Inc i%

    Wend

    _WriteLn txt$,0,1

ENDPROC

Proc ReadLn

    Déclarer read&,txt$
    Faible c_buf#,261
    ZeroMemory(c_buf#,261)
    ReadConsole(hinput&,c_buf#,261,Addr(read&),0)
    Laisser txt$=RemoveCR(String$(c_buf#,0))
    Dispose c_buf#
    Retour txt$

ENDPROC

Proc ReadOutput

    doit encore sur zeilenweises Lecture umgestellt volonté WG. CR
    Déclarer txt$,read&,size&
    GetScreenBufSize
    Laisser size&=&(0)
    Faible c_buf#,size&
    ZeroMemory(c_buf#,size&)
    ReadConsoleOutputCharacter(hscrbuf&,c_buf#,size&,0,Addr(read&))
    OemToCharBuff(c_buf#,c_buf#,read&)
    Laisser txt$=String$(c_buf#,0)
    Dispose c_buf#
    Laisser txt$=Translate$(txt$,   ,)
    Retour Trim$(txt$)
    Retour txt$

ENDPROC

Proc SetConsoleCaption

    Paramètres txt$
    Faible c_buf#,Ajouter(Len(txt$),1)
    String c_buf#,0=txt$
    SetConsoleTitle(c_buf#)
    Dispose c_buf#

ENDPROC

Proc GotoXY

    Paramètres x%,y%
    SetConsoleCursorPosition(hscrbuf&,MakeLong(% X, y%))

ENDPROC

Proc ClearConsole

    Paramètres color&
    Déclarer written&,size&
    GetScreenBufSize
    Laisser size&=&(0)
    Cas Lt(color&,7): Laisser color&=7
    FlushConsoleInputBuffer(hscrbuf&)
    SetConsoleTextAttribute(hscrbuf&,color&)
    Faible c_buf#,size&
    FillMemory(c_buf#,size&,32)
    WriteConsoleOutputCharacter(hscrbuf&,c_buf#,size&,0,Addr(written&))
    FillConsoleOutputAttribute(hscrbuf&,color&,size&,0,Addr(written&))
    Dispose c_buf#
    GotoXY 0,0

ENDPROC

Proc _CreateCon

    Paramètres title$,own_win%
    Cas own_win%: AllocConsole()
    SetConsoleCaption title$
    Laisser hinput&=GetStdHandle(-10)
    Laisser houtput&=GetStdHandle(-11)
    Laisser herror&=GetStdHandle(-12)
    Laisser hscrbuf&=houtput&
    SetConsoleMode(hscrbuf&,6)

ENDPROC

Proc CreateConsoleInWindow

    Paramètres txt$
    _CreateCon txt$,1

ENDPROC

Proc CreateConsole

    Paramètres txt$
    _CreateCon txt$,0

ENDPROC

Beispiel avec Mini-Befehls-Interpreter

Proc Beispiel_Ausgabe_Im_Fenster

    Déclarer c_exit%,txt$

    Proc Info

        WriteLn (c) 2000 Thomas Bois, Siegen, Alle Rechte vorbehalten

    ENDPROC

    Proc ShowHelp

        ClearConsole 31
        Info
        WriteLn
        WriteLn exit ou bien CTRL-C : finissons
        WriteLn ?                : Aider
        WriteLn cls              : Bildschirm effacer
        WriteLn about            : Info
        WriteLn

    ENDPROC

    CreateConsoleInWindow 32 Bit Profan²-Konsolen-la fenêtre - Powered by PRFellow 2001
    CreateConsole 32 Bit Profan²-Console - Powered by PRFellow 2001
    ClearConsole 31  sais sur bleu
    WriteLn donner vous ? pour Aider un et drücken vous ENTER

    WhileNot c_exit%

        ReadLn
        Laisser txt$=GetCleanInput()

        Si Equ$(txt$,)

        ElseIf Equ$(txt$,ABOUT)

            Info

        ElseIf Equ$(txt$,EXIT)

            Inc c_exit%

        ElseIf Equ$(txt$,?)

            ShowHelp

        ElseIf Equ$(txt$,CLS)

            ClearConsole 31

        D'autre

            WriteLn Ajouter$(Unbekannter Befehl: ,GetInput())

        EndIf

    Wend

    FreeConsole()
    ExitProcess(0)

ENDPROC

Beispiel_Ausgabe_Im_Fenster