XProfan

Declare h%,e%,a$,b$,c$,d$,e$,f$,g$
Declare Init$,Kanal1$,id%,Pause&
@CloseCom(COM1)

proc Pause

    let Pause& = &GetTickCount
    Let Pause& = @ADD(Pause&,100)

    while @GT(Pause&,&GetTickCount)

    wend

endproc

Font 1
let id% = COM1
LET h% = @OpenCom(id%,1024,1024)
@SetCom(id%:19200,N,8,1)
@SetComExt(id%,10,0,0,$0001,0,0)
LET f$ = @ReadCom$(id%,4)
Pause
LET g$ = @ComError(id%)
Pause
let Init$=CHR$(1),CHR$(5)CHR$(2),CHR$(6)
let Kanal1$=CHR$(3),CHR$(5),CHR$(8),CHR$(14)
print  Fehler  : ;@ComError(COM1)
@WriteCom(h%,Init$)
pause
@ReadCom$(id%,4)
Pause
@WriteCom(h%,Kanal1$)
Pause
print Init$
Print id%
LET f$ = @ReadCom$(id%,4)
Pause
print  Fehler  : ;@ComError(id%)
print  Gelesen : ;f$
Pause
print  Gelesen : ;@ReadCom$(id%,4)
Pause
@CloseCom(id%)

Bildschirmauflösung ist 1024*768
Xprofan 10                  sollte mit Xprofan 9 auch gehen
declare ende%,font&,kommando&,adresse&,daten&,pruef&,text&[30]	Bildschirmcontrols
declare init&,senden&,setzen&,ruecksetzen&
declare set&[8],reset&[8]
declare skommando%,sadresse%,sdaten%,spruef%			Sendebytes
declare ekommando%,eadresse%,edaten%,epruef%,hilfe%,hilfe1%	Empfangbytes
declare telegramm$,anzahl%
declare num%,num$,com1&,fehler%,x%,wert%,bwert$,aktion%,t$,n$,rahmen&[3]
usermessages 16
Def GetSysColor(1) !USER32, GetSysColor
font&=@Create(Font,Courier new,18,9,0,0,0)			Schriftfont
window 0,0-%maxx,%maxy						max.Fenstergrösse
cls getsyscolor (15)						Mit Systemfarbe löschen
kommando&=create(choicebox,%hwnd,1,50,120,45,210)
setfont kommando&,font&						Controls mit Schriftart bestücken
adresse&=create(choicebox,%hwnd,1,250,120,45,210)
setfont adresse&,font&						Controls mit Schriftart bestücken
daten&=create(edit,%hwnd,00000000,450,120,80,20)
setfont daten&,font&
sendmessage(daten&,$00CF,1,0)					Nur Leseedit
pruef&=create(edit,%hwnd,00000000,650,120,80,20)
setfont pruef&,font&						Controls mit Schriftart bestücken
sendmessage(pruef&,$00CF,1,0)					Nur Leseedit
init&=create(button,%hwnd,Init,50,300,50,20)
setfont init&,font&
senden&=create(button,%hwnd,Senden,50,600,60,20)
setfont senden&,font&
x%=50
num%=1

whilenot num% > 8

    set&[num%]=create(button,%hwnd,S,x%,420,20,20)
    reset&[num%]=create(button,%hwnd,R,x%+25,420,20,20)
    x%=x%+110
    inc num%

wend

Rahmen setzen
rahmen&[1]=@Create(GroupBox,%hwnd,Relaise Setzen und Rücksetzen,40,350,900,110)
setfont rahmen&[1],font&
rahmen&[2]=@Create(GroupBox,%hwnd,Die richtige Kartenadresse initialisieren,40,250,900,80)
setfont rahmen&[2],font&
===================== Ab hier Proceduren =======================================

Proc vorbereiten

    text&[0]=create(text,%hwnd,Alle voreingestellten Werte beziehen sich auf Karte eins. Die COM1 wird benutzt.,50,10,900,20)
    setfont text&[0],font&
    text&[1]=create(text,%hwnd,Kommando,50,90,100,20)
    setfont text&[1],font&
    text&[2]=create(text,%hwnd,Adresse,250,90,100,20)
    setfont text&[2],font&
    text&[3]=create(text,%hwnd,Daten,450,90,100,20)
    setfont text&[3],font&
    text&[4]=create(text,%hwnd,Pruefsumme,650,90,100,20)
    setfont text&[4],font&
    text&[5]=create(text,%hwnd,Die RS232 wurde ,50,40,600,20)
    setfont text&[5],font&
    text&[6]=create(text,%hwnd,nach Drücken von Init unter Adresse die  Kartennummer eingeben und Senden drücken ,130,300,750,20)
    setfont text&[6],font&
    text&[7]=create(text,%hwnd,Relais 1    Relais 2    Relais 3    Relais 4    Relais 5    Relais 6    Relais 7    Relais 8,50,380,850,20)
    setfont text&[7],font&
    text&[8]=create(text,%hwnd,Alle Ausgaben zur Karte werden durch Drücken des Sendebutton erst ausgegeben,120,600,850,20)
    setfont text&[8],font&
    text&[9]=create(text,%hwnd,Es wurden 0 Zeichen ausgegeben ,120,620,850,20)
    setfont text&[9],font&
    clear num%
    Kommandobox bis 6 und die Restlichen bis 8 bestücken

    whilenot num% > 8

        num$=right$(0+str$(num%),2)				aus 1 wird 01 usw.

        if num% < 6

            addstring(kommando&,num$)			Auswahlboxen mit Zahlen bestücken
            addstring(adresse&,num$)

        else

            addstring(adresse&,num$)

        endif

        inc num%

    wend

    Ende Bestücken
    Werte vorgeben
    SendMessage(kommando&,334,0,0)
    SendMessage(adresse&,334,0,0)
    SendMessage(daten&,334,0,0)
    COM1 öffnen und initialisieren
    com1& = @OpenCom(COM1,1024,1024)
    fehler% = @SetCom(com1&,COM1:19200,N,8,1)
    Ergebnis

    if fehler%=0

        settext text&[5],Die RS232 wurde erfolgreich geöffnet.

    else

        settext text&[5],Die RS232 konnte nicht geöffnet werden.

    endif

    num%=1

    whilenot num% > 8

        enablewindow reset&[num%],0
        inc num%

    wend

endproc

================================================================================

proc initial

    SendMessage(kommando&,334,1,0)
    SendMessage(adresse&,334,1,0)
    enablewindow kommando&,0				sperren
    settext daten&,00000000
    hilfe%=val(gettext$(kommando&))
    hilfe1%=val(gettext$(adresse&))
    spruef%=xor(hilfe%,hilfe1%)
    bwert$=right$(0000000+bin$(spruef%),8)
    settext pruef&,bwert$

endproc

=========================================================================

proc senden

    if aktion%=0

        Let t$=Bedienfehler
        Let n$=Erst Karte initialisieren !
        MessageBox(n$,t$,48)
        return

    endif

    enablewindow kommando&,1				freigeben
    skommando%=val(gettext$(kommando&))
    sadresse%=val(gettext$(adresse&))
    sdaten%=val(gettext$(daten&))
    telegramm$=chr$(skommando%)+chr$(sadresse%)+chr$(sdaten%)+chr$(spruef%)
    anzahl%=writecom(com1&,telegramm$)
    settext text&[9],Es wurden +str$(anzahl%)+  Zeichen ausgegeben.
    @ComError(com1&)

endproc

=================================================================

proc sauswerten

    beep
    case num%=1:wert%=wert%+1
    case num%=2:wert%=wert%+2
    case num%=3:wert%=wert%+4
    case num%=4:wert%=wert%+8
    case num%=5:wert%=wert%+16
    case num%=6:wert%=wert%+32
    case num%=7:wert%=wert%+64
    case num%=8:wert%=wert%+128
    enablewindow set&[num%],0
    enablewindow reset&[num%],1
    bwert$=right$(0000000+@Bin$(wert%),8)
    settext daten&,bwert$
    SendMessage(kommando&,334,3,0)
    SendMessage(adresse&,334,1,0)
    enablewindow kommando&,0
    fehlerbyte

endproc

=============================================================

proc rauswerten

    beep
    case wert% < 1:return
    case num%=1:wert%=wert%-1
    case num%=2:wert%=wert%-2
    case num%=3:wert%=wert%-4
    case num%=4:wert%=wert%-8
    case num%=5:wert%=wert%-16
    case num%=6:wert%=wert%-32
    case num%=7:wert%=wert%-64
    case num%=8:wert%=wert%-128
    enablewindow set&[num%],1
    enablewindow reset&[num%],0
    bwert$=right$(0000000+@Bin$(wert%),8)
    settext daten&,bwert$
    SendMessage(kommando&,334,3,0)
    SendMessage(adresse&,334,1,0)
    enablewindow kommando&,0
    fehlerbyte

endproc

==================================================

proc fehlerbyte

    hilfe%=val(gettext$(kommando&))
    hilfe1%=val(gettext$(adresse&))
    spruef%=xor(hilfe%,hilfe1%)
    hilfe%=val(gettext$(daten&))
    spruef%=xor(spruef%,hilfe%)
    bwert$=right$(0000000+bin$(spruef%),8)
    settext pruef&,bwert$

endproc

=================================================================
vorbereiten

whilenot ende%

    waitinput

    if %umessage = 16

        ende%=1
        closecom(com1&)
        deleteobject font&

    elseif clicked(init&)

        aktion%=1
        initial

    elseif clicked(senden&)

        senden

    elseif clicked(adresse&)

        fehlerbyte

    endif

    num%=1

    whilenot num% > 8

        case clicked(set&[num%]):sauswerten
        case clicked(reset&[num%]):rauswerten
        inc num%

    wend

wend

Steuerung von 1 Schranke, 10 Tore und 3 Lampengruppen über FMS-Signal per Funk und der AuswerteSoftware HEIRO
der Freiwilligen Feuerwehr Grevenbroich
dies ist der Script für zum öffnen der Schrank, Tor 10 öffnen und Innenbeleuchtung von Tor 10 - 1 einschalten.
es sind 2 Relaiskarten angeschlossen
die PRINT Befehle sind nur zu Prüfzwecken
Detlef Tussing
Mitglied der Freiwilligen Feuerwehr Grevenbroich
Bei den anfangsschwierigkeiten (Ich kenne XPROFAN erst seit Dezember 2006) hat mich GDL unterstüzt. Nochmal vielen Dank an dich
Declare d&,f$,g&,c&,a&,b&,E$,Bit0%,Bit1%,Bit2%,Bit3%,komando$,adresse$,Daten$,Prüfbit$,x&
ptype$(d&)
d& = @Opencom("COM1",1024,1024)
@Setcom("com1:19200,N,8,1")
comerror(d&)

Proc Senden         Prüfbit berechnen

    Bit0%=val(a&)
    Bit1%=val(b&)
    Bit3%=xor(bit0%,bit1%)
    Bit2%=val(c&)
    Bit3%= Xor(Bit3%,Bit2%)
    E$=chr$(a&)+chr$(b&)+chr$(c&)+chr$(Bit3%)
    Writecom(d&,E$)
    comerror(d&)
    sleep 500

Endproc

Proc Fehler

    MessageBox("Schranke und Tor konnte nicht geöffnet werden.
    Bitte manuell öffnen.","",48)
    closecom(d&)
    end

endproc

Proc Lesen

    while x&<16

        F$ = @Readcom$(D&,1)
        comerror(D&)
        sleep 50
        x&=x&+1
        print " lese : ";@ord(F$)

    endwhile

endproc

proc komando

    Komando$ = @Readcom$(D&,1)
    comerror(D&)
    sleep 50
    print " Status  : ";@ord(Komando$)

endproc

proc adresse

    Adresse$ = @Readcom$(D&,1)
    comerror(D&)
    sleep 50
    print " Adresse : ";@ord(Adresse$)

endproc

proc daten

    Daten$ = @Readcom$(D&,1)
    comerror(D&)
    sleep 50
    print " Daten   : ";@ord(Daten$)

endproc

proc prüfbit

    Prüfbit$ = @Readcom$(D&,1)
    comerror(D&)
    sleep 50
    print " Prüfbit : ";@ord(Prüfbit$)

endproc

a&=1
b&=1
c&=0
senden
lesen
a&=3    Sende
b&=1    an Karte 1
c&=1     Relais 1 ein Schranke auf
senden
komando

if @ord(Komando$)= 252   Prüfen ob der 1. Befehlsfolge fehlerfrei übertragen wurde

    Adresse

else

    Fehler

endif

if @ord(Adresse$)=1

    Daten

else

    Fehler

endif

if @ord(Daten$)= 1

    Prüfbit

else

    Fehler

endif

if @ord(Prüfbit$)= 252

    test

else

    Fehler

endif

b&=2  Karte 2
c& =4 Relais 3 ein Tor 10 auf
senden
b&=2  Karte 2
c&=60 Relis 4- 6 ein Lampengruppe 1- 3 an
senden
b&=0  Karte 1&2
c&=0  alle Relaiss aus
senden
closecom(D&)
waitinput
end

Shell "meinprogramm.exe 321"

declare myvar&
case %pcount : myvar&=val(par$(1))
nun liegt in myvar z.B. 321