The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 


  << Previous Topic | Next Topic >>Return to Index  

strange Get and Put error in SUB pred(it ruins the getted image) PS Run in qb 7.1

October 22 2006 at 5:33 AM
RubyNL  (no login)

DECLARE SUB pred ()
DECLARE SUB prepare ()
DECLARE SUB goconvert ()
DECLARE SUB openthis (path$, ext$)
DECLARE FUNCTION GetFileCount& (filespec$)
DECLARE SUB check ()
DEFINT A-Z
DECLARE FUNCTION position% (col%, row%, ding$, wich%)
DECLARE SUB calculatesize ()
DECLARE SUB converttogrey (x1, y1, x2, y2)
DECLARE SUB changecolor (slot, R, g, B)
DECLARE FUNCTION colorslot (slot, a$)
DECLARE SUB converttomask (x1, y1, x2, y2)
DECLARE SUB gifload (a$)
DECLARE FUNCTION InitMOUSE ()
DECLARE SUB MouseSTATUS (LB, RB, MouseX, MouseY)
DECLARE SUB showmouse ()
DECLARE SUB hidemouse ()
DECLARE SUB LocateMOUSE (x, y)
DECLARE SUB FieldMOUSE (x1, y1, x2, y2)
DECLARE SUB PauseMOUSE (LB, RB, MouseX, MouseY)
DECLARE SUB ClearMOUSE ()
DECLARE SUB MouseDRIVER (LB, RB, MX, MY)
'$DYNAMIC 'this allows more memory assignment in compiled programs

TYPE RegType
AX AS INTEGER
BX AS INTEGER
cx AS INTEGER
DX AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
END TYPE

IF NOT InitMOUSE THEN
PRINT "Your damned mouse dont work. "
PRINT "Sorry, but it isn't my fault."
PRINT "Press a key to exit and press no key to not exit."
SLEEP
END
END IF
CLS
SCREEN 12
DIM SHARED files$(1), number
DIM SHARED lp, oe, e
DIM SHARED LB, RB, MouseX, MouseY


B$ = " "
DIM SHARED ptopx1, ptopy1, ptopx2, ptopy2, ptop$
ptopx1 = position(2, 5, B$, 1) - 1
ptopy1 = position(2, 5, B$, 2) - 1
ptopx2 = position(2, 5, B$, 3) + 1
ptopy2 = position(2, 5, B$, 4) + 1

a$ = "x Save mask to:"
DIM SHARED smtx1, smty1, smtx2, smty2, smt
smt = 1
smtx1 = position(1, 7, a$, 1)
smty1 = position(1, 7, a$, 2)
smtx2 = position(1, 7, a$, 3)
smty2 = position(1, 7, a$, 4)

DIM SHARED smtpx1, smtpy1, smtpx2, smtpy2, smtp$
smtpx1 = position(2, 8, B$, 1) - 1
smtpy1 = position(2, 8, B$, 2) - 1
smtpx2 = position(2, 8, B$, 3) + 1
smtpy2 = position(2, 8, B$, 4) + 1

a$ = "x Save picture to:"
DIM SHARED sptx1, spty1, sptx2, spty2, spt
spt = 1
sptx1 = position(1, 10, a$, 1)
spty1 = position(1, 10, a$, 2)
sptx2 = position(1, 10, a$, 3)
spty2 = position(1, 10, a$, 4)

DIM SHARED sptpx1, sptpy1, sptpx2, sptpy2, sptp$
sptpx1 = position(2, 11, B$, 1) - 1
sptpy1 = position(2, 11, B$, 2) - 1
sptpx2 = position(2, 11, B$, 3) + 1
sptpy2 = position(2, 11, B$, 4) + 1

a$ = "x Open every file in directory"
DIM SHARED oefx1, oefy1, oefx2, oefy2, oef
oef = 1
oefx1 = position(1, 13, a$, 1)
oefy1 = position(1, 13, a$, 2)
oefx2 = position(1, 13, a$, 3)
oefy2 = position(1, 13, a$, 4)

a$ = "x Convert to greyscale"
DIM SHARED ctgx1, ctgy1, ctgx2, ctgy2, ctg
ctg = 1
ctgx1 = position(1, 14, a$, 1)
ctgy1 = position(1, 14, a$, 2)
ctgx2 = position(1, 14, a$, 3)
ctgy2 = position(1, 14, a$, 4)

a$ = "x pixels"
DIM SHARED px1, py1, px2, py2, p
p = 1
px1 = position(23, 17, a$, 1)
py1 = position(23, 17, a$, 2)
px2 = position(23, 17, a$, 3)
py2 = position(23, 17, a$, 4)

a$ = "x number of images"
DIM SHARED nx1, ny1, nx2, ny2, n
n = 1
nx1 = position(23, 18, a$, 1)
ny1 = position(23, 18, a$, 2)
nx2 = position(23, 18, a$, 3)
ny2 = position(23, 18, a$, 4)

B$ = " "

DIM SHARED bx1, by1, bx2, by2, be$
bx1 = position(8, 15, B$, 1) - 1
by1 = position(8, 15, B$, 2) - 1
bx2 = position(8, 15, B$, 3) + 1
by2 = position(8, 15, B$, 4) + 1

DIM SHARED pxx1, pxy1, pxx2, pxy2, px$
pxx1 = position(7, 17, B$, 1) - 1
pxy1 = position(7, 17, B$, 2) - 1
pxx2 = position(7, 17, B$, 3) + 1
pxy2 = position(7, 17, B$, 4) + 1

DIM SHARED pyx1, pyy1, pyx2, pyy2, py$
pyx1 = position(15, 17, B$, 1) - 1
pyy1 = position(15, 17, B$, 2) - 1
pyx2 = position(15, 17, B$, 3) + 1
pyy2 = position(15, 17, B$, 4) + 1

DIM SHARED nxx1, nxy1, nxx2, nxy2, nx$
nxx1 = position(7, 18, B$, 1) - 1
nxy1 = position(7, 18, B$, 2) - 1
nxx2 = position(7, 18, B$, 3) + 1
nxy2 = position(7, 18, B$, 4) + 1

DIM SHARED nyx1, nyy1, nyx2, nyy2, ny$
nyx1 = position(15, 18, B$, 1) - 1
nyy1 = position(15, 18, B$, 2) - 1
nyx2 = position(15, 18, B$, 3) + 1
nyy2 = position(15, 18, B$, 4) + 1

a$ = " GO "
DIM SHARED gox1, goy1, gox2, goy2
gox1 = position(17, 23, a$, 1) - 1
goy1 = position(17, 23, a$, 2) - 1
gox2 = position(17, 23, a$, 3) + 1
goy2 = position(17, 23, a$, 4) + 1

a$ = "Display image"
DIM SHARED dix1, diy1, dix2, diy2
dix1 = position(25, 23, a$, 1) - 1
diy1 = position(25, 23, a$, 2) - 1
dix2 = position(25, 23, a$, 3) + 1
diy2 = position(25, 23, a$, 4) + 1


prepare
showmouse
DO UNTIL h$ = CHR$(27)
h$ = INKEY$
MouseSTATUS LB, RB, MouseX, MouseY
check
'LOCATE 27, 10: PRINT MouseX \ 8 + 1
'LOCATE 27, 14: PRINT MouseY \ 16 + 1
LOOP
'hidemouse
'gifload "C:/a.gif"
'DIM SHARED xsize, ysize, getsize
'calculatesize
'converttogrey 0, 0, xsize, ysize
'changecolor 150, 0, 0, 63

REM $STATIC
SUB Blur (x1, y1, x2, y2)
FOR y = y1 TO y2
FOR x = x1 TO x2
a = POINT(x, y)
j = a / 5
FOR a = -1 TO 1
FOR B = -1 TO 1
IF a = 0 OR B = 0 THEN
c = POINT(x + a, y + B) + j
IF x + a <= x2 AND x + a >= x1 AND y + B <= y2 AND y + B >= y1 THEN PSET (x + a, y + B), c
ELSE
PSET (x, y), j
END IF
NEXT
NEXT
NEXT
NEXT
END SUB

REM $DYNAMIC
SUB calculatesize
DO UNTIL xf = 1 AND yf = 1
IF xf = 0 THEN x = x + 1
IF xf = 1 THEN y = y + 1
IF POINT(x, y) = 0 THEN
IF xf = 1 THEN y = y - 1: yf = 1
IF xf = 0 THEN x = x - 1: xf = 1
END IF
LOOP
xsize = x
ysize = y
getsize = INT(((xsize + 1) * (ysize + 1) / 2) + 1.5)
'IF getsize MOD 2 = 1 THEN getsize = getsize + 1
END SUB

REM $STATIC
SUB changecolor (slot, R, g, B)
OUT &H3C8, slot
OUT &H3C9, R
OUT &H3C9, g
OUT &H3C9, B
END SUB

SUB check
IF LB = -1 THEN
IF MouseX >= ptopx1 AND MouseX <= ptopx2 AND MouseY >= ptopy1 AND MouseY <= ptopy2 THEN
hidemouse
LOCATE 5, 2: INPUT "", ptop$
showmouse
ELSEIF MouseX >= smtx1 AND MouseX <= smtx2 AND MouseY >= smty1 AND MouseY <= smty2 AND lp <> 1 THEN
hidemouse
lp = 1
IF smt = 1 THEN
smt = 0: LOCATE 7, 1: PRINT " "
ELSE
smt = 1: LOCATE 7, 1: PRINT "x"
END IF
showmouse
ELSEIF smt = 1 AND MouseX >= smtpx1 AND MouseX <= smtpx2 AND MouseY >= smtpy1 AND MouseY <= smtpy2 THEN
hidemouse
LOCATE 8, 2: INPUT "", smtp$
showmouse
ELSEIF MouseX >= pxx1 AND MouseX <= pxx2 AND MouseY >= pxy1 AND MouseY <= pxy2 THEN
hidemouse
LOCATE 17, 7: INPUT "", px$
showmouse
ELSEIF MouseX >= pyx1 AND MouseX <= pyx2 AND MouseY >= pyy1 AND MouseY <= pyy2 THEN
hidemouse
LOCATE 17, 15: INPUT "", py$
showmouse
ELSEIF MouseX >= nxx1 AND MouseX <= nxx2 AND MouseY >= nxy1 AND MouseY <= nxy2 THEN
hidemouse
LOCATE 18, 7: INPUT "", nx$
showmouse
ELSEIF MouseX >= nyx1 AND MouseX <= nyx2 AND MouseY >= nyy1 AND MouseY <= nyy2 THEN
hidemouse
LOCATE 18, 15: INPUT "", ny$
showmouse
ELSEIF MouseX >= sptx1 AND MouseX <= sptx2 AND MouseY >= spty1 AND MouseY <= spty2 AND lp <> 2 THEN
hidemouse
lp = 2
IF spt = 1 THEN
spt = 0: LOCATE 10, 1: PRINT " "
ELSE
spt = 1: LOCATE 10, 1: PRINT "x"
END IF
showmouse
ELSEIF spt = 1 AND MouseX >= sptpx1 AND MouseX <= sptpx2 AND MouseY >= sptpy1 AND MouseY <= sptpy2 THEN
hidemouse
LOCATE 11, 2: INPUT "", sptp$
showmouse
ELSEIF spt = 1 AND MouseX >= bx1 AND MouseX <= bx2 AND MouseY >= by1 AND MouseY <= by2 THEN
hidemouse
LOCATE 15, 8: INPUT "", be$
showmouse
ELSEIF MouseX >= oefx1 AND MouseX <= oefx2 AND MouseY >= oefy1 AND MouseY <= oefy2 AND lp <> 3 THEN
hidemouse
lp = 3
IF oef = 1 THEN
oef = 0: LOCATE 13, 1: PRINT " "
ELSE
oef = 1: LOCATE 13, 1: PRINT "x"
END IF
showmouse
ELSEIF MouseX >= px1 AND MouseX <= px2 AND MouseY >= py1 AND MouseY <= py2 AND lp <> 6 THEN
hidemouse
lp = 6
IF p = 1 THEN
p = 0: LOCATE 17, 23: PRINT " "
ELSE
p = 1: LOCATE 17, 23: PRINT "x"
END IF
showmouse
ELSEIF MouseX >= nx1 AND MouseX <= nx2 AND MouseY >= ny1 AND MouseY <= ny2 AND lp <> 7 THEN
hidemouse
lp = 7
IF n = 1 THEN
n = 0: LOCATE 18, 23: PRINT " "
ELSE
n = 1: LOCATE 18, 23: PRINT "x"
END IF
showmouse
ELSEIF MouseX >= ctgx1 AND MouseX <= ctgx2 AND MouseY >= ctgy1 AND MouseY <= ctgy2 AND lp <> 4 THEN
hidemouse
lp = 4
IF ctg = 1 THEN
ctg = 0: LOCATE 14, 1: PRINT " "
ELSE
ctg = 1: LOCATE 14, 1: PRINT "x"
END IF
showmouse
ELSEIF MouseX >= gox1 AND MouseX <= gox2 AND MouseY >= goy1 AND MouseY <= goy2 THEN
goconvert
ELSEIF MouseX >= dix1 AND MouseX <= dix2 AND MouseY >= diy1 AND MouseY <= diy2 THEN
pred
END IF
ELSE
lp = 0
oe = e
IF MouseX >= dix1 AND MouseX <= dix2 AND MouseY >= diy1 AND MouseY <= diy2 THEN e = 4
IF MouseX >= gox1 AND MouseX <= gox2 AND MouseY >= goy1 AND MouseY <= goy2 THEN e = 3
IF n = 0 AND p = 0 THEN e = 2
IF smt = 0 AND spt = 0 THEN e = 1
IF (p = 1 OR n = 1) AND (smt = 1 OR spt = 1) AND (MouseX < gox1 OR MouseX > gox2 OR MouseY < goy1 OR MouseY > goy2) AND (MouseX < dix1 OR MouseX > dix2 OR MouseY < diy1 OR MouseY > diy2) THEN e = 0
IF oe <> e THEN
LOCATE 28, 1: PRINT " "
SELECT CASE e
CASE 1
LOCATE 28, 1: PRINT "!You have to chose between save mask to and save picture to!"
CASE 2
LOCATE 28, 1: PRINT "!You have to chose the number of images or the x- and ysize of them!"
CASE 3
LOCATE 28, 1: PRINT "Click here to start. Take care you have filled in everything correctly."
CASE 4
LOCATE 28, 1: PRINT "Only display the current image on the current path."
END SELECT
END IF
END IF
END SUB

SUB ClearMOUSE
DIM R AS RegType
R.AX = 3
DO: CALL interrupt(51, R, R)
LOOP WHILE R.BX
END SUB

FUNCTION colorslot (slot, a$)
OUT &H3C7, slot
R = INP(&H3C9)
g = INP(&H3C9)
B = INP(&H3C9)
IF UCASE$(a$) = "R" OR UCASE$(a$) = "RED" THEN colorslot = R
IF UCASE$(a$) = "G" OR UCASE$(a$) = "GREEN" THEN colorslot = g
IF UCASE$(a$) = "B" OR UCASE$(a$) = "BLUE" THEN colorslot = B
END FUNCTION

SUB converttogrey (x1, y1, x2, y2)
FOR x = x1 TO x2
FOR y = y1 TO y2
curcol = POINT(x, y)
R = colorslot(curcol, "r")
g = colorslot(curcol, "g")
B = colorslot(curcol, "b")
PSET (x, y), (R + B + g) / 3
NEXT
NEXT
FOR a = 1 TO 63
changecolor a, a, a, a
NEXT
END SUB

SUB converttomask (x1, y1, x2, y2)
backgroundcolor = POINT(x1, y1)
FOR x = x1 TO x2
FOR y = y1 TO y2
IF POINT(x, y) = backgroundcolor THEN
PSET (x, y), 255
ELSE
PSET (x, y), 0
END IF
NEXT
NEXT
END SUB

SUB FieldMOUSE (x1, y1, x2, y2)
DIM R AS RegType
R.AX = 7
R.cx = x1
R.DX = x2
CALL interrupt(51, R, R)

R.AX = 8
R.cx = y1
R.DX = y2
CALL interrupt(51, R, R)

END SUB

FUNCTION GetFileCount& (filespec$)
DIM FileCount AS LONG

'IF LEN(DIR$(filespec$)) = 0 THEN 'Ensure filespec is valid.
FileCount& = 0 'It's not.
'ELSE
FileCount = 1 'It is, so count files.
DO WHILE LEN(DIR$) > 0
FileCount& = FileCount& + 1
LOOP
'END IF
GetFileCount = FileCount&
END FUNCTION

DEFSNG A-Z
SUB gifload (a$)
DEFINT A-Z
DIM Prefix(4095), Suffix(4095), OutStack(4095), shiftout(8)
DIM Ybase AS LONG, powersof2(11) AS LONG, WorkCode AS LONG

FOR a = 0 TO 7: shiftout(8 - a) = 2 ^ a: NEXT a
FOR a = 0 TO 11: powersof2(a) = 2 ^ a: NEXT a
IF a$ = "" THEN PRINT "Please input GIF-file:": INPUT "", a$: IF a$ = "" THEN END
IF INSTR(a$, ".") = 0 THEN a$ = a$ + ".gif"
OPEN a$ FOR BINARY AS #1
a$ = " ": GET #1, , a$
IF a$ <> "GIF87a" THEN PRINT "Not a GIF87a file.": END
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((a AND 7) + 1): NoPalette = (a AND 128) = 0
GOSUB GetByte: Background = a
GOSUB GetByte: IF a <> 0 THEN PRINT "Bad screen descriptor.": END
IF NoPalette = 0 THEN p$ = SPACE$(NumColors * 3): GET #1, , p$
DO
GOSUB GetByte
IF a = 44 THEN
EXIT DO
ELSEIF a <> 33 THEN
PRINT "Unknown extension type.": END
END IF
GOSUB GetByte
DO: GOSUB GetByte: a$ = SPACE$(a): GET #1, , a$: LOOP UNTIL a = 0
LOOP
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength: GOSUB GetByte
IF a AND 128 THEN PRINT "Can't handle local colormaps.": END
Interlaced = a AND 64: PassNumber = 0: PassStep = 8
GOSUB GetByte
ClearCode = 2 ^ a
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = a + 1: CodeSize = StartCodeSize
StartMaxCode = 2 ^ (a + 1) - 1: MaxCode = StartMaxCode

BitsIn = 0: BlockSize = 0: BlockPointer = 1
x = XStart: y = YStart: Ybase = y * 320&

DEF SEG = &HA000
IF NoPalette = 0 THEN
OUT &H3C7, 0: OUT &H3C8, 0
FOR a = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(p$, a, 1)) \ 4: NEXT a
END IF
LINE (0, 0)-(319, 199), Background, BF
DO
GOSUB GetCode
IF Code <> EOSCode THEN
IF Code = ClearCode THEN
NextCode = FirstCode
CodeSize = StartCodeSize
MaxCode = StartMaxCode
GOSUB GetCode
CurCode = Code: LastCode = Code: LastPixel = Code
IF x < 320 THEN POKE x + Ybase, LastPixel
x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
ELSE
CurCode = Code: StackPointer = 0
IF Code > NextCode THEN EXIT DO
IF Code = NextCode THEN
CurCode = LastCode
OutStack(StackPointer) = LastPixel
StackPointer = StackPointer + 1
END IF

DO WHILE CurCode >= FirstCode
OutStack(StackPointer) = Suffix(CurCode)
StackPointer = StackPointer + 1
CurCode = Prefix(CurCode)
LOOP

LastPixel = CurCode
IF x < 320 THEN POKE x + Ybase, LastPixel
x = x + 1: IF x = XEnd THEN GOSUB NextScanLine

FOR a = StackPointer - 1 TO 0 STEP -1
IF x < 320 THEN POKE x + Ybase, OutStack(a)
x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
NEXT a

IF NextCode < 4096 THEN
Prefix(NextCode) = LastCode
Suffix(NextCode) = LastPixel
NextCode = NextCode + 1
IF NextCode > MaxCode AND CodeSize < 12 THEN
CodeSize = CodeSize + 1
MaxCode = MaxCode * 2 + 1
END IF
END IF
LastCode = Code
END IF
END IF
LOOP UNTIL DoneFlag OR Code = EOSCode
'BEEP
'A$ = INPUT$(1)
CLOSE #1
EXIT SUB

GetByte: a$ = " ": GET #1, , a$: a = ASC(a$): RETURN

NextScanLine:
IF Interlaced THEN
y = y + PassStep
IF y >= YEnd THEN
PassNumber = PassNumber + 1
SELECT CASE PassNumber
CASE 1: y = 4: PassStep = 8
CASE 2: y = 2: PassStep = 4
CASE 3: y = 1: PassStep = 2
END SELECT
END IF
ELSE
y = y + 1
END IF
x = XStart: Ybase = y * 320&: DoneFlag = y > 199
RETURN
GetCode:
IF BitsIn = 0 THEN GOSUB ReadBufferedByte: LastChar = a: BitsIn = 8
WorkCode = LastChar \ shiftout(BitsIn)
DO WHILE CodeSize > BitsIn
GOSUB ReadBufferedByte: LastChar = a
WorkCode = WorkCode OR LastChar * powersof2(BitsIn)
BitsIn = BitsIn + 8
LOOP
BitsIn = BitsIn - CodeSize
Code = WorkCode AND MaxCode
RETURN
ReadBufferedByte:
IF BlockPointer > BlockSize THEN
GOSUB GetByte: BlockSize = a
a$ = SPACE$(BlockSize): GET #1, , a$
BlockPointer = 1
END IF
a = ASC(MID$(a$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN
END SUB

SUB goconvert
IF ptop$ <> "" AND ((smt = 0 OR smtp$ <> "") OR (spt = 0 OR sptp$ <> "")) THEN
IF oef = 1 THEN
openthis ptop$, "GIF"
ELSE
number = 1: files$(1) = ptop$
END IF
hidemouse
gifload files$(1)
calculatesize
DIM lilpic(24 * 32 / 2 + 1)
FOR xxx = 1 TO number
IF ctg = 1 THEN converttogrey 0, 0, xsize, ysize
IF spt = 1 THEN
FOR x = 1 TO 3
FOR y = 1 TO 4
GET ((x - 1) * 24, (y - 1) * 32)-(x * 24 - 1, y * 32 - 1), lilpic(0)
DEF SEG = VARSEG(lilpic(0))
BSAVE sptp$, VARPTR(lilpic(0)), 0
DEF SEG
NEXT
NEXT
END IF
IF smt = 1 THEN
converttomask 0, 0, xsize, ysize

END IF

IF xxx + 1 <= number THEN gifload files$(xxx + 1)
NEXT
showmouse
END IF
END SUB

SUB hidemouse
DIM R AS RegType
R.AX = 2
CALL interrupt(51, R, R)
END SUB

FUNCTION InitMOUSE
DIM R AS RegType
R.AX = 0
CALL interrupt(51, R, R)
InitMOUSE = R.AX
END FUNCTION

SUB LocateMOUSE (x, y)
DIM R AS RegType
R.AX = 3
CALL interrupt(51, R, R)
x = R.cx
y = R.DX
END SUB

SUB MouseSTATUS (LB, RB, MouseX, MouseY)
DIM R AS RegType
R.AX = 3
CALL interrupt(51, R, R)
LB = -(R.BX AND 1)
RB = (R.BX AND 2) <> 0
MouseX = R.cx
MouseY = R.DX
END SUB

SUB openthis (path$, ext$)
IF RIGHT$(path$, 1) <> "/" THEN path$ = path$ + "/"
files$ = path$ + "*." + ext$
number = GetFileCount(files$)
REDIM files$(number)
'files$(1) = path$ + DIR$(files$)
FOR x = 2 TO number
files$(x) = path$ + DIR$
NEXT
END SUB

SUB PauseMOUSE (OldLB, OldRB, OldMX, OldMY)
SHARED Key$
DO
Key$ = UCASE$(INKEY$)
MouseSTATUS LB, RB, MouseX, MouseY
LOOP UNTIL LB <> OldLB OR RB <> OldRB OR MouseX <> OldMX OR MouseY <> OldMY OR Key$ <> ""
END SUB

FUNCTION position (col%, row%, ding$, wich%)
SELECT CASE wich%
CASE 1
position = (col% - 1) * 8
CASE 2
position = ((row% - 1) * 8) * 2
CASE 3
position = (col% + LEN(ding$) - 1) * 8
CASE 4
position = ((row%) * 8) * 2
END SELECT
END FUNCTION

SUB pred
DIM picture(2 * 3889)
hidemouse
CLS
SCREEN 13
PRINT "Press TAB to switch instructions."
PRINT "Press ENTER to continue."
DO UNTIL INKEY$ = CHR$(13): LOOP

CLS
SLEEP
PRINT "Press TAB to switch instructions on/off"
PRINT "Press F1 to convert to greyscale, SPACE"
PRINT "to exit, F2 to convert to mask..."
SLEEP
GET (0, 0)-(310, 24), picture(3889)
CLS
'c$ = ptop$
'gifload ptop$
GET (0, 175)-(310, 199), picture(0)
'ptop$ = c$
e = 1
DO UNTIL h$ = CHR$(32)
h$ = INKEY$
od = d
IF h$ = CHR$(9) THEN SWAP d, e
IF od <> d THEN PUT (0, 175), picture(d * 3889), PSET
LOOP
'SCREEN 12
'CLS
'prepare
'showmouse
END
END SUB

SUB prepare
LOCATE 1, 1: PRINT "Welcome to Qu-By Convert"
LOCATE 4, 1: PRINT " Path to open:"

LOCATE 5, 2: PRINT ptop$
LINE (ptopx1, ptopy1)-(ptopx2, ptopy2), 15, B

a$ = " Save mask to:": IF smt = 1 THEN a$ = "x Save mask to:"
LOCATE 7, 1: PRINT a$

LOCATE 8, 2: PRINT smtp$
LINE (smtpx1, smtpy1)-(smtpx2, smtpy2), 15, B

a$ = " Save picture to:": IF spt = 1 THEN a$ = "x Save picture to:"
LOCATE 10, 1: PRINT a$

a$ = " Open every file in directory": IF oef = 1 THEN a$ = "x Open every file in directory"
LOCATE 13, 1: PRINT a$

a$ = " Convert to greyscale": IF ctg = 1 THEN a$ = "x Convert to greyscale"
LOCATE 14, 1: PRINT a$

LOCATE 15, 8: PRINT be$
LOCATE 15, 3: PRINT "Blur"
LOCATE 15, 15: PRINT "times."
LINE (bx1, by1)-(bx2, by2), 15, B

LOCATE 11, 2: PRINT sptp$
LINE (sptpx1, sptpy1)-(sptpx2, sptpy2), 15, B

a$ = " pixels": IF p = 1 THEN a$ = "x pixels"
LOCATE 17, 23: PRINT a$
LOCATE 18, 13: PRINT "x"

a$ = " number of images": IF n = 1 THEN a$ = "x number of images"
LOCATE 17, 13: PRINT "x"
LOCATE 18, 23: PRINT a$

LOCATE 17, 7: PRINT px$
LINE (pxx1, pxy1)-(pxx2, pxy2), 15, B

LOCATE 17, 15: PRINT py$
LINE (pyx1, pyy1)-(pyx2, pyy2), 15, B

LOCATE 18, 7: PRINT nx$
LINE (nxx1, nxy1)-(nxx2, nxy2), 15, B

LOCATE 18, 15: PRINT ny$
LINE (nyx1, nyy1)-(nyx2, nyy2), 15, B

a$ = " GO "
LOCATE 23, 17: PRINT a$
LINE (gox1, goy1)-(gox2, goy2), 15, B

a$ = "Display image"
LOCATE 23, 25: PRINT a$
LINE (dix1, diy1)-(dix2, diy2), 15, B

END SUB

SUB scale (x11, y11, x12, y12, x21, y21, x22, y22)
xs1 = x12 - x11
ys1 = y12 - y11
xs2 = x22 - x21
ys2 = y22 - y21
xfrag! = xs2 / xs1
yfrag! = ys2 / ys1
IF xfrag! > 1 OR yfrag! > 1 THEN
cx! = x21: cy! = y21
FOR y = y11 TO y12
FOR x = x11 TO x12
LINE (cx!, cy!)-(cx! + xfrag! - 1, cy! + xfrag! - 1), POINT(x, y), BF
cx! = cx! + xfrag!
NEXT
cy! = cy! + yfrag!: cx! = x21
NEXT
ELSE
FOR y = y21 TO y22
FOR x = x21 TO x22
PSET (x, y), POINT((x - x21 + x11) / xfrag!, (y - y21 + y11) / yfrag!)
NEXT
NEXT
END IF
END SUB

SUB showmouse
DIM R AS RegType
R.AX = 1
CALL interrupt(51, R, R)
END SUB


 

 Respond to this message   
Current Topic - strange Get and Put error in SUB pred(it ruins the getted image) PS Run in qb 7.1
  << Previous Topic | Next Topic >>Return to Index  
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums