XProfan

PRFellow-Presentation
Author: Thomas Hölzer - any rights vorbehalten
example-Program for a fenstergebundene Konsole
needs Profan 6.1 because of Addr-function
(Umstellung on Profan 5.0 with Memory-Variable is possible)
(c) 2000 Thomas Hölzer, Siegen - any rights 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&))  with WideChar * 2, but we take 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

    must yet on zeilenweises Reading umgestellt go 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

example with Mini-Befehls-Interpreter

Proc Beispiel_Ausgabe_Im_Fenster

    Declare c_exit%,txt$

    Proc Info

        WriteLn (c) 2000 Thomas Hölzer, Siegen, any rights vorbehalten

    ENDPROC

    Proc ShowHelp

        ClearConsole 31
        Info
        WriteLn
        WriteLn exit or CTRL-C : terminate
        WriteLn ?                : Help
        WriteLn cls              : screen delete
        WriteLn about            : Info
        WriteLn

    ENDPROC

    CreateConsoleInWindow 32 bit Profan²-Konsolen-Window - Powered by PRFellow 2001
    CreateConsole 32 bit Profan²-Konsole - Powered by PRFellow 2001
    ClearConsole 31  white on blue
    WriteLn give tappt im dunkeln ? for Help one and pressing tappt im dunkeln 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 commands: ,GetInput())

        EndIf

    Wend

    FreeConsole()
    ExitProcess(0)

ENDPROC

Beispiel_Ausgabe_Im_Fenster