| |
PA3BNX > ALL 11.01.06 01:12l 520 Lines 9220 Bytes #999 (0) @ WW
BID : 5945_PI8SHB
Read: GUEST
Subj: TstHost Rem source.
Path: DB0FHN<DB0FOR<DB0SIF<DB0ROF<DB0ERF<DB0FBB<DB0BI<DB0NOS<DB0EA<DB0RES<
DK0WUE<7M3TJZ<ON0AR<OZ5BBS<PI8ZAA<PI8SHB
Sent: 060109/1319Z @:PI8SHB.#NBO.NLD.EU #:5945 ['s-Hertogenbosch] $:5945_PI8SHB
From: PA3BNX@PI8SHB.#NBO.NLD.EU
To : ALL@WW
Hello all,
Here i sent for comments etc the source of my lptremote tsthostprogram
under qb45.
cut here.
---------
DECLARE SUB datadivice ()
DECLARE FUNCTION searchold$ (newlptpins AS STRING)
DECLARE SUB welcome ()
DECLARE SUB readcall ()
DECLARE FUNCTION StripSSID$ (effe AS STRING)
DECLARE FUNCTION reverse$ (effe AS STRING)
DECLARE SUB logging ()
DECLARE SUB setlpt ()
DECLARE SUB helponscreen ()
DECLARE FUNCTION dec2bin$ (dec AS INTEGER)
DECLARE FUNCTION bin2dec! (bin AS STRING)
DECLARE SUB checkcall ()
DECLARE SUB getlpt ()
DECLARE SUB extractcommand ()
DECLARE SUB datacall ()
DECLARE FUNCTION divicelist! ()
''((C)) PA3BNX LPT-PROGRAM for TSTHost143c 29-12-2005.
''Constants.
CONST ve$ = "((C))PA3BNX LPT Remote Version 1.07"
''Where is the pg dir.
CONST path = "c:\tst\pg\"
CONST lptlog$ = "lptlog.txt"
CONST callsfile$ = "lptcall.txt"
CONST progname$ = " REM "''Think of spaces begin and end in helponscreen.
''Arrays.
DIM SHARED Allowedcalls(1 TO 10) AS STRING ''Call list.
DIM SHARED tekst(1 TO 10) AS STRING ''The extracted command$tring.
DIM SHARED divice(1 TO 8) AS STRING
DIM SHARED diviceadress(1 TO 8) AS STRING
''Variables.
COMMON SHARED port AS INTEGER
COMMON SHARED nopath AS INTEGER
COMMON SHARED nolist AS INTEGER
COMMON SHARED callsign AS STRING
COMMON SHARED sessie AS STRING
COMMON SHARED commando AS STRING
COMMON SHARED lptpins AS STRING
IF COMMAND$ = "" THEN
PRINT "Use it in TSTHOST143c"
END
END IF
''Test routines.
CLS
'PRINT COMMAND$
ON ERROR GOTO 500
''Main program.
'=========================================================
CALL logging ''Logging all recieved commands.
start:
CALL extractcommand ''Extract callsign, sessie and command.
CALL readcall ''Reading permission calls from file.
FURTHER:
CALL datadivice ''Divice list
CALL checkcall ''Check for call permissie.
CALL welcome ''Gives welcome + undeline.
CALL helponscreen ''Help text and or stop <lpt1 and >lpt4.
CALL getlpt
CALL setlpt
PRINT
PRINT ve
BEEP
SYSTEM
'==========================================================
''Error trap.
500 :
IF ERR = 53 OR ERR = 76 THEN
IF nopath = 0 THEN
CALL datacall ''No callsfile$ found.
GOTO FURTHER
ELSEIF nopath = 1 THEN ''Path found.
GOTO start
END IF
ELSE
PRINT "Error" + STR$(ERR) + " occurred."
END IF
'==========================================================
SYSTEM
FUNCTION bin2dec (bin AS STRING)
''Convert string binair to decimaal long.
DIM x AS INTEGER
DIM y AS INTEGER
DIM z AS INTEGER
DIM length AS INTEGER
DIM j AS INTEGER
bin = LTRIM$(bin)
bin = RTRIM$(bin)
length = LEN(bin)
FOR j = length TO 1 STEP -1
x = VAL(MID$(bin, j, 1))
IF x = 1 AND j = length THEN
x = 0
ELSEIF x = 1 THEN
x = 2
ELSE
GOTO under
END IF
y = y + (x ^ z)
under:
z = z + 1
NEXT j
bin2dec = y
END FUNCTION
SUB checkcall
''Check here for calls allowed.
DIM x AS INTEGER
DIM y AS INTEGER
y = UBOUND(Allowedcalls)
FOR x = 1 TO y
IF UCASE$(StripSSID$(Allowedcalls(x))) = StripSSID$(callsign) THEN
EXIT SUB
END IF
NEXT x
PRINT "No permission to do that " + callsign + "."
END
END SUB
SUB datacall
''All calls allowed to set the lptport.
Allowedcalls(1) = StripSSID$(callsign)
''Specified calls only allowed.
'allowedcalls(1) = "PA3BNX"
'allowedcalls(2) = "G8MNY"
'allowedcalls(3) = "PA0CVW"
'allowedcalls(4) = "PA0PDO"
END SUB
SUB datadivice
''Adjust here the table.
divice(1) = "Off"
diviceadress(1) = "00000000"
divice(5) = "12Volt"
diviceadress(5) = "xxxx1xxx"
divice(6) = "Lamp1"
diviceadress(6) = "xxxxx1xx"
divice(7) = "Radio"
diviceadress(7) = "xxxxxx1x"
divice(8) = "Lamp2"
diviceadress(8) = "xxxxxxx1"
END SUB
FUNCTION dec2bin$ (dec AS INTEGER)
''Convert here decimal integer to bin string
''Like 10 = "01001000"
'' lsb>msb
''Max 255. Always length 8 string
'From decimal to binairy methode.
'46/2=23 rest 0
'23/2=11 rest 1
'11/2=5 rest 1
' 5/2=2 rest 1
' 2/2=1 rest 0
' 1/2 = 0 rest 1
'So 46 = 101110
DIM rest(0 TO 20) AS INTEGER
DIM x AS INTEGER
DIM y AS INTEGER
DIM effe AS INTEGER
DIM b AS STRING
FOR x = 0 TO 20
rest(x) = 0
NEXT x
x = 0
effe = dec
DO UNTIL effe = 0
rest(x) = effe MOD 2
effe = effe \ 2
x = x + 1
LOOP
FOR y = 7 TO 0 STEP -1
b = b + LTRIM$(STR$(rest(y)))
NEXT y
dec2bin = b
END FUNCTION
FUNCTION divicelist
''Swith here by just names.
DIM x AS INTEGER
DIM y AS INTEGER
IF LEN(tekst(3)) = 0 THEN EXIT FUNCTION
FOR x = 1 TO 8
IF tekst(3) = UCASE$(divice(x)) THEN
port = 632
lptpins = diviceadress(x)
lptpins = reverse$(diviceadress(x))
IF LCASE$(divice(x)) = "off" THEN
PRINT "All switched off."
ELSE
PRINT divice(x) + " = switched on."
END IF
divicelist = 1
EXIT FUNCTION
END IF
NEXT x
END FUNCTION
SUB extractcommand
''Extract here call, sessie and command from tsthost.
''PA3BNX-1 0 %1
DIM i AS INTEGER
DIM x AS INTEGER
DIM y AS INTEGER
DIM z AS INTEGER
DIM effe AS STRING
y = 1
z = LEN(COMMAND$)
''Search for spaces.
DO
i = i + 1
FOR x = y TO z
IF MID$(COMMAND$, x, 1) <> " " THEN
tekst(i) = tekst(i) + MID$(COMMAND$, x, 1)
ELSE
EXIT FOR
END IF
NEXT x
IF x < z AND i < 10 THEN
y = x + 1
ELSE
EXIT DO
END IF
LOOP
''Assign the datafields.
callsign = tekst(1)
sessie = tekst(2)
commando = tekst(3)
''No more then 8 chars.
''No less then 8 chars hi.
''Or empty
z = LEN(tekst(4))
IF z > 8 THEN tekst(4) = MID$(tekst(4), 1, 8)
IF z < 8 AND z <> 0 THEN
DO UNTIL LEN(tekst(4)) = 8
tekst(4) = tekst(4) + "x"
LOOP
END IF
lptpins = reverse$(tekst(4))
END SUB
SUB getlpt
PRINT "Old LPT &h" + HEX$(port) + " = " + reverse$(dec2bin(INP(port)))
END SUB
SUB helponscreen
''Here some print routines for help.
DIM z AS INTEGER
z = LEN(commando)
IF divicelist = 1 THEN EXIT SUB
IF commando = "?" THEN
PRINT "Possible devices:"
FOR x = 1 TO UBOUND(divice)
IF LEN(divice(x)) > 0 THEN
PRINT divice(x)
END IF
NEXT x
PRINT ve
END
END IF
IF MID$(commando, 1, 3) <> "LPT" OR LEN(commando) <= 3 THEN
PRINT "Use" + progname$ + "LPT1 xxx0xxxx to set the lptpins remotely."
PRINT "xxxxxxxx means pin 2 > pin 9 of a db25 lpt connector."
PRINT "So x means does not care, 1 = on and 0 = off."
PRINT "LPT1 just gives the status of lpt1."
PRINT
PRINT ve
END
END IF
''To short string.
IF z < 4 AND MID$(commando, 1, 3) <> "LPT" THEN END
''Out of range.
IF VAL(MID$(commando, 4, 1)) > 3 OR VAL(MID$(commando, 4, 1)) < 1 THEN END
''Select lpt portnumber.
SELECT CASE VAL(MID$(commando, 4, 1))
CASE 1
port = 888
CASE 2
port = 956
CASE 3
port = 632
END SELECT
''Just show the lptstatus.
IF z = 4 AND lptpins = "" THEN
CALL getlpt
END
END IF
END SUB
SUB logging
''Here logging of all cmd's.
nopath = 0''Path not found yet.
OPEN path + lptlog$ FOR APPEND AS #1
WRITE #1, COMMAND$, DATE$, TIME$
CLOSE #1
nopath = 1 ''Path found.
END SUB
SUB readcall
''Read here the permission calls.
DIM x AS INTEGER
DIM effe AS STRING
'PRINT path + callsfile$
nopath = 0 ''Path not found yet.
nolist = 0''List not found yet.
OPEN path + callsfile$ FOR INPUT AS #1
DO
x = x + 1
INPUT #1, effe
Allowedcalls(x) = UCASE$(effe)
LOOP UNTIL EOF(1) OR x = UBOUND(Allowedcalls)
CLOSE #1
nopath = 1''Path found.
nolist = 1''List found.
END SUB
FUNCTION reverse$ (effe AS STRING)
''Reverse a string here.
DIM x AS INTEGER
DIM effe2 AS STRING
FOR x = LEN(effe) TO 1 STEP -1
effe2 = effe2 + MID$(effe, x, 1)
NEXT x
reverse$ = effe2
END FUNCTION
FUNCTION searchold$ (newlptpins AS STRING)
''Returns a string
''Search Old lptpins and new and combine them.
DIM x AS INTEGER
DIM oldpins AS STRING
DIM effe AS STRING
DIM myval AS STRING
''Get old lptpins.
''Get new lptpins.
''Combine lptpins.
''Search for x,0,1
''Oldpins does only contain 0 and 1's.
oldpins = dec2bin(INP(port))
FOR x = 1 TO 8
myval = LCASE$(MID$(newlptpins, x, 1))
IF myval = "x" OR myval = "." THEN effe = effe + MID$(oldpins, x, 1)
IF myval = "1" THEN effe = effe + "1"
IF myval = "0" THEN effe = effe + "0"
NEXT x
searchold = effe
END FUNCTION
SUB setlpt
''Set here the lptport.
DIM x AS INTEGER
''Limit to max 8.
IF LEN(lptpins) > 8 THEN lptpins = MID$(lptpins, 1, 8)
x = bin2dec(searchold(lptpins))
OUT (port), x''Set the pins.
'Show the user te settings
'Reverse it again hi...
PRINT "New LPT &h" + HEX$(port) + " = " + reverse$(dec2bin(x))
END SUB
FUNCTION StripSSID$ (effe AS STRING)
'Strip here ssid from calls
'pa3bnx-2 becomes pa3bnx
DIM x AS INTEGER
DIM effe2 AS STRING
FOR x = 1 TO LEN(effe)
IF MID$(effe, x, 1) <> "-" THEN
effe2 = effe2 + MID$(effe, x, 1)
ELSE
EXIT FOR
END IF
NEXT x
StripSSID$ = effe2
END FUNCTION
SUB welcome
DIM effe AS STRING
DIM effe1 AS STRING
IF nolist = 0 THEN effe1 = " All welcome."
effe = "Hello " + callsign + " @ " + TIME$ + "." + effe1
PRINT effe
FOR x = 1 TO LEN(effe)
PRINT "-";
NEXT x
PRINT
END SUB
-------------
Cut here.
Suk6 and let me now if you have tips to improve it.
73's from Lodewijk QTH Rhenen JO21SX.
5157.80N/00534.23E
PA3BNX@PI8SHB.#NBO.NLD.EU
IP nr. 44.137.40.41.
Read previous mail | Read next mail
| |
