XProfan

PRFellow-Vorlage
Autor: Thomas Hölzer - Alle Rechte vorbehalten
Beispiel-Programm für eine fenstergebundene Konsole
Benötigt Profan 6.1 wegen Addr-Funktion
(Umstellung auf Profan 5.0 mit Bereichsvariable ist möglich)
(c) 2000 Thomas Hölzer, 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),Add$(Chr$(13),Chr$(10)),Chr$(32))
Declare hinput&,houtput&,herror&,hscrbuf&
Declare BUF_INFO#,c_buf#
Declare INPUT_REC#

Proc GetScreenBufSize

    Declare size&
    Dim BUF_INFO#,20
    GetConsoleScreenBufferInfo(hscrbuf&,BUF_INFO#)
    Let size&=Long(BUF_INFO#,0)
    Let size&=Mul(LoWord(size&),HiWord(size&))  bei WideChar * 2, aber wir nehmen ANSI
    Dispose BUF_INFO#
    Return size&

EndProc

Proc LineColor

    Parameters fg%,bg%
    Declare colattr&
    Let colattr&=Or(fg%,Mul(bg%,4))
    SetConsoleTextAttribute(hscrbuf&,colattr&)

EndProc

Proc _WriteLn

    Parameters txt$,oem_convert%,cr%
    Declare written&
    Let txt$=txt$
    Case cr%: Let txt$=txt$;Chr$(13);Chr$(10)
    Dim c_buf#,Add(Len(txt$),1)
    String c_buf#,0=txt$
    Case 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

    Parameters txt$
    _Writeln txt$,1,0

EndProc

Proc WriteCR

    _Writeln ,0,1

EndProc

Proc WriteLn

    Declare txt$,i%
    Let i%=1

    WhileNot Gt(i%,%pcount)

        Let txt$=Add$(txt$,$(i%))
        Inc i%

    Wend

    _Writeln txt$,1,1

EndProc

Proc WriteCGI

    Parameters txt$
    _Writeln txt,0,0

EndProc

Proc WriteLnCGI

    Declare txt$,i%
    Let i%=1

    WhileNot Gt(i%,%pcount)

        Let txt$=Add$(txt$,$(i%))
        Inc i%

    Wend

    _WriteLn txt$,0,1

EndProc

Proc ReadLn

    Declare read&,txt$
    Dim c_buf#,261
    ZeroMemory(c_buf#,261)
    ReadConsole(hinput&,c_buf#,261,Addr(read&),0)
    Let txt$=RemoveCR(String$(c_buf#,0))
    Dispose c_buf#
    Return txt$

EndProc

Proc ReadOutput

    muß noch auf zeilenweises Auslesen umgestellt werden wg. CR
    Declare txt$,read&,size&
    GetScreenBufSize
    Let size&=&(0)
    Dim c_buf#,size&
    ZeroMemory(c_buf#,size&)
    ReadConsoleOutputCharacter(hscrbuf&,c_buf#,size&,0,Addr(read&))
    OemToCharBuff(c_buf#,c_buf#,read&)
    Let txt$=String$(c_buf#,0)
    Dispose c_buf#
    Let txt$=Translate$(txt$,   ,)
    Return Trim$(txt$)
    Return txt$

EndProc

Proc SetConsoleCaption

    Parameters txt$
    Dim c_buf#,Add(Len(txt$),1)
    String c_buf#,0=txt$
    SetConsoleTitle(c_buf#)
    Dispose c_buf#

EndProc

Proc GotoXY

    Parameters x%,y%
    SetConsoleCursorPosition(hscrbuf&,MakeLong(x%,y%))

EndProc

Proc ClearConsole

    Parameters color&
    Declare written&,size&
    GetScreenBufSize
    Let size&=&(0)
    Case Lt(color&,7): Let color&=7
    FlushConsoleInputBuffer(hscrbuf&)
    SetConsoleTextAttribute(hscrbuf&,color&)
    Dim 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

    Parameters title$,own_win%
    Case own_win%: AllocConsole()
    SetConsoleCaption title$
    Let hinput&=GetStdHandle(-10)
    Let houtput&=GetStdHandle(-11)
    Let herror&=GetStdHandle(-12)
    Let hscrbuf&=houtput&
    SetConsoleMode(hscrbuf&,6)

EndProc

Proc CreateConsoleInWindow

    Parameters txt$
    _CreateCon txt$,1

EndProc

Proc CreateConsole

    Parameters txt$
    _CreateCon txt$,0

EndProc

Beispiel mit Mini-Befehls-Interpreter

Proc Beispiel_Ausgabe_Im_Fenster

    Declare c_exit%,txt$

    Proc Info

        WriteLn (c) 2000 Thomas Hölzer, Siegen, Alle Rechte vorbehalten

    EndProc

    Proc ShowHelp

        ClearConsole 31
        Info
        WriteLn
        WriteLn exit oder CTRL-C : Beenden
        WriteLn ?                : Hilfe
        WriteLn cls              : Bildschirm löschen
        WriteLn about            : Info
        WriteLn

    EndProc

    CreateConsoleInWindow 32 Bit Profan²-Konsolen-Fenster - Powered by PRFellow 2001
    CreateConsole 32 Bit Profan²-Konsole - Powered by PRFellow 2001
    ClearConsole 31  weiß auf blau
    WriteLn Geben Sie ? für Hilfe ein und drücken Sie ENTER

    WhileNot c_exit%

        ReadLn
        Let txt$=GetCleanInput()

        If Equ$(txt$,)

        ElseIf Equ$(txt$,ABOUT)

            Info

        ElseIf Equ$(txt$,EXIT)

            Inc c_exit%

        ElseIf Equ$(txt$,?)

            ShowHelp

        ElseIf Equ$(txt$,CLS)

            ClearConsole 31

        Else

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

        EndIf

    Wend

    FreeConsole()
    ExitProcess(0)

EndProc

Beispiel_Ausgabe_Im_Fenster