XProfan

PRFellow-Presentación
Autor: Thomas Hölzer - Alle Rechte vorbehalten
Ejemplo-Programa para una fenstergebundene Konsole
Benötigt Profano 6.1 wegen Addr-Función
(Interruptor en Profano 5.0 con Bereichsvariable es posible)
(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))
Declarar hinput&,houtput&,herror&,hscrbuf&
Declarar BUF_INFO#,c_buf#
Declarar INPUT_REC#

Proc GetScreenBufSize

    Declarar size&
    Dim BUF_INFO#,20
    GetConsoleScreenBufferInfo(hscrbuf&,BUF_INFO#)
    Let size&=Largo(BUF_INFO#,0)
    Let size&=Mul(LoWord(size&),HiWord(size&))  en WideChar * 2, aber wir nehmen ANSI
    Disponer BUF_INFO#
    Volver size&

ENDPROC

Proc LineColor

    Parámetros fg%,bg%
    Declarar colattr&
    Let colattr&=Or(fg%,Mul(bg%,4))
    SetConsoleTextAttribute(hscrbuf&,colattr&)

ENDPROC

Proc _WriteLn

    Parámetros txt$,oem_convert%,cr%
    Declarar 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)
    Disponer c_buf#

ENDPROC

Proc Write

    Parámetros txt$
    _Writeln txt$,1,0

ENDPROC

Proc WriteCR

    _Writeln ,0,1

ENDPROC

Proc WriteLn

    Declarar txt$,i%
    Let i%=1

    Sinestar encargado Gt(i%,%pcount)

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

    Wend

    _Writeln txt$,1,1

ENDPROC

Proc WriteCGI

    Parámetros txt$
    _Writeln txt,0,0

ENDPROC

Proc WriteLnCGI

    Declarar txt$,i%
    Let i%=1

    Sinestar encargado Gt(i%,%pcount)

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

    Wend

    _WriteLn txt$,0,1

ENDPROC

Proc ReadLn

    Declarar 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))
    Disponer c_buf#
    Volver txt$

ENDPROC

Proc ReadOutput

    muß todavía en zeilenweises Auslesen umgestellt voluntad ca. CR
    Declarar 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)
    Disponer c_buf#
    Let txt$=Translate$(txt$,   ,)
    Volver Trim$(txt$)
    Volver txt$

ENDPROC

Proc SetConsoleCaption

    Parámetros txt$
    Dim c_buf#,Add(Len(txt$),1)
    String c_buf#,0=txt$
    SetConsoleTitle(c_buf#)
    Disponer c_buf#

ENDPROC

Proc GotoXY

    Parámetros x%,y%
    SetConsoleCursorPosition(hscrbuf&,MakeLong(X%, y%))

ENDPROC

Proc ClearConsole

    Parámetros color&
    Declarar 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&))
    Disponer c_buf#
    GotoXY 0,0

ENDPROC

Proc _CreateCon

    Parámetros 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

    Parámetros txt$
    _CreateCon txt$,1

ENDPROC

Proc CreateConsole

    Parámetros txt$
    _CreateCon txt$,0

ENDPROC

Ejemplo con Mini-Befehls-Interpreter

Proc Beispiel_Ausgabe_Im_Fenster

    Declarar 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 ?                : Ayuda
        WriteLn cls              : Bildschirm löschen
        WriteLn about            : Info
        WriteLn

    ENDPROC

    CreateConsoleInWindow 32 Bit Profano²-Konsolen-Ventana - Powered by PRFellow 2001
    CreateConsole 32 Bit Profano²-Konsole - Powered by PRFellow 2001
    ClearConsole 31  weiß en blau
    WriteLn Geben Sie ? para Ayuda una y drücken Sie ENTER

    Sinestar encargado 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

        Más

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

        EndIf

    Wend

    FreeConsole()
    ExitProcess(0)

ENDPROC

Beispiel_Ausgabe_Im_Fenster