回 帖 发 新 帖 刷新版面

主题:DOS下的qbasic写的读BMP文件程序

实在老了一点,那时还不知道declare,用gosub做的,呵呵:),可以读取未压缩的2、
16和256色的BMP图(现在高版本的bmp已经不行了:|),写得很糟糕,但是不想改了,毕竟是自己的发展历程,代表了自己当时的水平。
顺便给一张图做测试
[img]http://www.wodutom.com/coolwindows/VIEW_01.BMP[/img]

main:
        DEFINT A, I-J, T', X-Y
        DIM dy AS INTEGER, colo AS INTEGER, size AS LONG, tmp AS INTEGER
        DIM co0 AS INTEGER, co1 AS INTEGER, wite1 AS INTEGER, high AS INTEGER
        DO
                SCREEN 0: CLS
                        GOSUB First
                INPUT "All file name(*.bmp):", filename$
                IF filename$ = "" THEN EXIT DO
                        GOSUB OpenFile
                IF of = 0 THEN CLOSE : rerr = 1: GOSUB ErrorInfo: GOTO main
                        GOSUB CheckBmp
                IF check = 0 THEN CLOSE : rerr = 2: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadBit
                        GOSUB ReadColor
                IF colo = 0 THEN CLOSE : rerr = 3: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadWH
                IF w = 0 THEN CLOSE : rerr = 4: GOSUB ErrorInfo: GOTO main
                IF h = 0 THEN CLOSE : rerr = 5: GOSUB ErrorInfo: GOTO main
                        GOSUB zip
                IF zip = 1 THEN CLOSE : rerr = 6: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadPalette
                IF bit = 8 THEN SCREEN 13 ELSE SCREEN 12
                        GOSUB SetPalette
                        GOSUB ViewPicture
                        GOSUB AscKey
lop:
                GOSUB Last
        LOOP
        CLS
END

First:
        DIM pixel(8) AS INTEGER: x = 0: y = 1
        filename$ = ""
        of = 0: check = 0: colo = 0: wite = 0: high = 0: done = 0: change = 0
        xb = 1: yb = 1: full = 0
        OUT &H3C6, 255
        RANDOMIZE TIMER
        'FILES "*.bmp"
        'PRINT
RETURN

Last:
        ERASE pixel
        CLOSE #1
        SCREEN 12
        typ = 0
        CLS
RETURN

OpenFile: '(filename$|of)
        IF filename$ = "h" OR filename$ = "H" THEN GOTO Help
        a$ = RIGHT$(filename$, 1)
        n = LEN(filename$)
        ture = 1: pot = 0: pat = 0
        FOR i = 1 TO n
                a$ = RIGHT$(LEFT$(filename$, i), 1)
                IF a$ = "*" OR a$ = "+" OR a$ = "=" OR a$ = "<" OR a$ = ">" OR a$ = "[" OR a$ = "]" OR a$ = ";" OR a$ = CHR$(34) OR a$ = "?" OR a$ = "|" THEN ture = 0: EXIT FOR
                IF a$ = "/" AND i <> n THEN ture = 0
                IF a$ = "." AND i = 1 THEN ture = 0
                IF a$ = "." THEN pot = pot + 1
        NEXT
        IF pot > 1 THEN ture = 0
        IF ture = 0 THEN rerr = 7: GOSUB ErrorInfo: GOTO main
        IF a$ = "/" THEN filename$ = LEFT$(filename$, LEN(filename$) - 1): full = 1
        OPEN filename$ FOR RANDOM AS #1
        CLOSE
        OPEN filename$ FOR INPUT AS #1
                IF EOF(1) THEN of = 0: CLOSE : KILL filename$:  ELSE of = 1
RETURN

CheckBmp: '(|check)
        SEEK #1, 1
        IF INPUT$(2, 1) = "BM" THEN check = 1 ELSE check = 0
RETURN

ReadColor: '(|colo,typ)
        SEEK #1, &H2F
        colo = ASC(INPUT$(1, 1))
        IF colo = 0 THEN IF bit = 8 THEN colo = 256 ELSE colo = 16
        IF colo <= 16 THEN typ = 1 ELSE IF colo > 256 THEN colo = 0
RETURN

ReadWH: '(|wite,high)
        DIM temp(8)
        i = &H13
        FOR j = 1 TO 8
                SEEK #1, i
                temp(j) = ASC(INPUT$(1, 1))
                i = i + 1
        NEXT
        SEEK #1, &H23
        a$ = INPUT$(3, 1)
        size = ASC(LEFT$(a$, 1)) / 16 + ASC(RIGHT$(LEFT$(a$, 2), 1)) * 16 + ASC(RIGHT$(a$, 1)) * 4096
        wite1 = temp(2) * 256 + temp(1)
        high = (temp(6) * 256 + temp(5))
        wite = CINT((size / high) * (8 / bit) * 16)
        IF wite = 0 THEN wite = wite1
        IF full = 1 THEN
                IF bit < 8 THEN xb = 640 / wite1: yb = 480 / high ELSE xb = 320 / wite1: yb = 200 / high
        END IF
        high = high * yb
        IF full = 0 THEN
                IF typ = 1 THEN
                        IF wite1 * wb > 640 AND wite1 > 640 THEN w = 0 ELSE w = 1
                        IF high > 480 THEN h = 0 ELSE h = 1
                ELSE
                        IF wite1 * wb > 320 AND wite1 > 320 THEN w = 0 ELSE w = 1
                        IF high > 200 THEN h = 0 ELSE h = 1
                END IF
        ELSE
                w = 1: h = 1
        END IF
        dy = high - 1
        ERASE temp
RETURN

zip: '(|zip)
        DIM a(4): zip = 0
        i = &H1F
        FOR j = 1 TO 4
                SEEK #1, i
                a(j) = ASC(INPUT$(1, 1))
                IF a(j) <> 0 THEN zip = 1: EXIT FOR
                i = i + 1
        NEXT
        ERASE a
RETURN

ReadPalette: '(colo|pal(dat))
        dat = colo * 4
        DIM pal(dat) AS INTEGER
        i = &H37
        SEEK #1, i
        FOR j = 1 TO dat
                IF EOF(1) THEN
                        i = i + 1
                        SEEK #1, i
                        pal(j) = INT(26 / 4)
                ELSE
                        pal(j) = INT(ASC(INPUT$(1, 1)) / 4)
                        i = i + 1
                END IF
        NEXT
RETURN

SetPalette: '(pal(dat))
        IF done = 0 THEN
                IF typ = 1 THEN
                        IF colo < 15 THEN PALETTE 15, 0: LINE (0, 0)-(639, 479), 15, BF
                ELSE
                        IF colo < 255 THEN PALETTE 255, 0: LINE (0, 0)-(319, 199), 255, BF
                END IF
                cotmp = POINT(0, 0): LOCATE 1, 1: PRINT "Setting..."
        END IF
        OUT &H3C8, 0
        IF change = 0 THEN
                FOR i = 1 TO dat STEP 4
                        OUT &H3C9, pal(i + 2)
                        OUT &H3C9, pal(i + 1)
                        OUT &H3C9, pal(i)
                        IF INP(&H60) = 1 THEN ERASE pal: GOTO lop
                NEXT
        ELSE
                FOR i = 1 TO dat STEP 4
                        OUT &H3C9, 63 - pal(i + 2)
                        OUT &H3C9, 63 - pal(i + 1)
                        OUT &H3C9, 63 - pal(i)
                        IF INP(&H60) = 1 THEN ERASE pal: GOTO lop
                NEXT
        END IF
        IF done = 0 THEN LINE (0, 0)-(79, 15), cotmp, BF
RETURN

ReadBit: '(|bit)
        SEEK #1, &H1D
        bit = ASC(INPUT$(1, 1))
RETURN

ViewPicture: '(colo,bit)
        SEEK #1, &HB
        a$ = INPUT$(2, 1)
        record = ASC(RIGHT$(a$, 1)) * 256 + ASC(LEFT$(a$, 1)) + 1
        SEEK #1, record
        FOR time = 1 TO 5000
                DO
                        IF EOF(1) THEN EXIT DO
                        temp = ASC(INPUT$(1, 1))
                        GOSUB Dec2Bin
                        record = record + 1
                        IF INP(&H60) = 1 THEN GOTO lop
                LOOP
                IF dy < 0 THEN EXIT FOR
                record = record + 1
                SEEK #1, record
                temp = 26
                GOSUB Dec2Bin
        NEXT
        xd = 1: yd = 1: a$ = "OK!": GOSUB PutCh
RETURN

Dec2Bin: '(colo,temp)
        IF x >= wite THEN y = y + yb: x = 0: dy = CINT(high - y)
        IF bit < 8 THEN
                FOR i = 1 TO 8
                        pixel(i) = INT(temp / (2 ^ (8 - i))): temp = temp MOD (2 ^ (8 - i))
                NEXT
                IF bit = 1 THEN
                        IF xb <= 1 THEN
                                IF yb > 1 THEN FOR tmp = 0 TO 7: LINE (x * xb + tmp, dy - yb)-(x * xb + tmp, dy), pixel(tmp + 1), BF: NEXT ELSE FOR tmp = 0 TO 7: PSET (x * xb + tmp, dy), pixel(tmp + 1): NEXT
                        ELSE
                                a = 0: t = 1
                                FOR temp1 = 1 TO 8
                                        FOR temp = a TO t * CINT(xb) - 1
                                                LINE (x * xb + temp, dy - yb)-(x * xb + temp + 1, dy), pixel(temp1), BF
                                        NEXT
                                        a = t * CINT(xb): t = t + 1
                                 NEXT
                        END IF
                        x = x + 8
                ELSE
                        co0 = pixel(1) * 8 + pixel(2) * 4 + pixel(3) * 2 + pixel(4)
                        co1 = pixel(5) * 8 + pixel(6) * 4 + pixel(7) * 2 + pixel(8)
                        IF xb <= 1 THEN
                                IF yb > 1 THEN
                                        LINE (x * xb, dy - yb)-(x * xb, dy), co0, BF: LINE (x * xb + 1, dy - yb)-(x * xb + 1, dy), co1, BF
                                ELSE
                                        PSET (x * xb, dy), co0: PSET (x * xb + 1, dy), co1
                                END IF
                        ELSE
                                FOR temp = 0 TO CINT(xb) - 1
                                        LINE (x * xb + temp, dy - yb)-(x * xb + temp + 1, dy), co0, BF
                                NEXT
                                FOR temp = CINT(xb) TO 2 * (CINT(xb)) - 1
                                        LINE (x * xb + temp, dy - yb)-(x * xb + temp + 1, dy), co1, BF
                                NEXT
                        END IF
                        x = x + 2
                END IF
        ELSE
                IF x < wite1 THEN
                        IF xb <= 1 THEN
                                IF yb > 1 THEN
                                        LINE (x * xb, dy - yb)-(x * xb, dy), temp, BF
                                ELSE
                                        PSET (x * xb, dy), temp
                                END IF
                        ELSE
                                FOR tmp = 0 TO CINT(xb) - 1
                                        LINE (x * xb + tmp, dy - yb)-(x * xb + tmp + 1, dy), temp, BF
                                NEXT
                        END IF
                END IF
                x = x + 1
        END IF
RETURN

AscKey:
        DO: i$ = INKEY$
                IF i$ <> "" THEN
                        SELECT CASE i$
                                CASE "c"
                                        OUT &H3C8, 0
                                        FOR i = 1 TO colo
                                                OUT &H3C9, INT(RND * 64)
                                                OUT &H3C9, INT(RND * 64)
                                                OUT &H3C9, INT(RND * 64)
                                        NEXT
                                        'xd = 1: yd = 1: a$ = "OK!": GOSUB PutCh
                                CASE "r"
                                        done = 1: change = 0
                                        GOSUB SetPalette
                                        'xd = 1: yd = 1: a$ = "OK!": GOSUB PutCh
                                CASE "n"
                                        done = 1: change = 1
                                        GOSUB SetPalette
                                        'xd = 1: yd = 1: a$ = "OK!": GOSUB PutCh
                                CASE "q": ERASE pal: EXIT DO
                                CASE CHR$(27): ERASE pal: EXIT DO
                        END SELECT
                END IF
        LOOP 'UNTIL INP(&H60) = 1
RETURN

ErrorInfo: '(rerr)
        SOUND 1200, .5
        COLOR 12, 0
        PRINT "ERROR: ";
        SELECT CASE rerr
                CASE 1: PRINT "File not found!"
                CASE 2: PRINT "It's not a BMP file!"
                CASE 3: PRINT "This program can't support this FORMAT!"
                CASE 4: PRINT "Width is too Large, MAX: 640(Color16);320(Color256)!  Width="; wite
                        COLOR 11, 0: PRINT CHR$(13) + "You may try input:'"; : COLOR 10, 0: PRINT filename$; "/"; : COLOR 11, 0: PRINT "' to carry out it."
                CASE 5: PRINT "Height is too Large, MAX: 480(Color16);200(Color256)!  Hight="; high
                        COLOR 11, 0: PRINT CHR$(13) + "You may try input:'"; : COLOR 10, 0: PRINT filename$; "/"; : COLOR 11, 0: PRINT "' to carry out it."
                CASE 6: PRINT "This file had been Compressed, I can't view it!"
                CASE 7: PRINT "Error Filename!"
        END SELECT
        COLOR 14, 0: PRINT CHR$(13) + "You can input 'H' or 'h' to Read the Help"
        COLOR 7, 0: PRINT CHR$(13) + "press any key to Return..."
        a$ = INPUT$(1)
RETURN

PutCh: '(xd,yd,a$)
        a = LEN(a$)
        DIM pc%(a * 8 * 16)
        GET (0, 0)-(a * 8 - 1, 15), pc%
        LOCATE yd, xd: PRINT a$
        PUT (0, 0), pc%, AND
        DO: LOOP UNTIL INKEY$ <> ""
        PUT (0, 0), pc%, PSET
        ERASE pc%
RETURN

Help:
        CLS
        COLOR 14, 0: LOCATE 1, 38: PRINT "HELP"
        COLOR 15, 0: PRINT CHR$(13) + "This program can show a BMP File which has not been Compressed."
        COLOR 13, 0: PRINT CHR$(13) + "You can use it like this:"
        PRINT "  When the SYSTEM says:'All file name(*.bmp):', you should input the file name  which you want to watch, Include '.BMP' or input 'H' to look this instruction,  then SYSTEM will carry out your Command. If you input nothing,you will QUIT thisSYSTEM."
        COLOR 11, 0: PRINT CHR$(13) + "About ERROR:"
        PRINT "  1.File not found! (means can't find this file in the Directory) !! you can    input Other File Name or COPY the File to this Directory to Solve it."
        PRINT "  2.It's not a BMP file! (means the Inputed File is not a BMP File) !! you must input Other File Name again."
        PRINT "  3.This program can't support this FORMAT! (means the file maybe use TureColor, this program only can view the File of which the Color Less then 256.)":
        PRINT "  4.Width is too Large...! (means the width of the file is too Large) !! you may view it like this:" + CHR$(34) + "All file name(*.bmp):'"; : COLOR 12, 0: PRINT "filename/"; : COLOR 11, 0: PRINT "'" + CHR$(34) + "."
        PRINT "  5.Height is too Large...! (means the height of the file is too Large) !! Way: As the Same as 4."
        PRINT CHR$(13) + "press any key to contine..."
        DO: LOOP UNTIL INKEY$ <> ""
        PRINT
        PRINT "  6.This file had been Compressed...! (means it is a Compressed File) !! I'm    sorry, I can do nothing with it."
        PRINT "  7.Error Filename!(means  it is not a legal filename) !! you must input legal  filename."
        COLOR 10, 0: PRINT CHR$(13) + "About CORTROL:"
        PRINT "  Parameter:'/' (input it Behind File Name when SYSTEM tell you to input file   name.) >> show the file ALL SCREEN."
        PRINT "  xb: >> it's in the program, but you can use it to Change Width to Width*xb."
        PRINT "  yb: >> it's in the program, but you can use it to Change Height to Height*yb."
        PRINT "  Key Cortrol: use it when the file show Complete."
        PRINT "    'c': >> Set the Color of the file Randomize."
        PRINT "    'n': >> Carry out Negative Color."
        PRINT "    'r': >> Return the Right Color."
        PRINT "    'q' or 'ESC': >> Quit View."
        PRINT CHR$(13) + "press any key to return..."
        DO: LOOP UNTIL INKEY$ <> ""
        COLOR 7, 0
        GOTO main


回复列表 (共15个回复)

沙发

真的太棒了。我想你一定是一个qb高手。真的佩服你的精神。现在很少有人能够静下心来写一些优秀的qb程序了。
都怪世界变话太快了,但是我这一个保守分子还是从qb学起来了,开始是觉得基础好学,现在不那么看了,因为通过几个月的学习自己的收获很大。也喜欢上了qb,我觉得任何一门语言重要的是学精通他,达到你那样的水平才有资格去考虑学别的。我会努力象你那样学好qb的。

板凳

祝你成功,如果有问题,可以随时找我探讨!

3 楼

谢谢了
现在还是开始那,还有许多的东西要去学,
我信心努力了,就一定有收获的。
谢谢鼓励。以后还要麻烦你了

4 楼

GOOD

5 楼

一句话,小弟是菜鸟看不懂。

6 楼

请woshihanjin兄弟把算法流程贴上来好不好?或者在程序中加上注释。这样我等也好看得明白些。有劳了。

7 楼

[em18] 我弄了一张 1086×869 的 ACDSee BMP Image ,是用 Photoshop 7.0 做的,他怎么显示 ERROR!?

8 楼

如今很好有人会用QB写这样好的程序了!!!!!!
   GOOD  
  项!!!!!

9 楼

回7楼,只能640*480*16

10 楼

把最长的一条分开了,QB4.5不支持" _"注意是字符,不是笑脸,7.0/7.1可以支持

main:
        DEFINT A, I-J, T', X-Y
        DIM dy AS INTEGER, colo AS INTEGER, size AS LONG, tmp AS INTEGER
        DIM co0 AS INTEGER, co1 AS INTEGER, wite1 AS INTEGER, high AS INTEGER
        DO
                SCREEN 0: CLS
                        GOSUB First
                INPUT "All file name(*.bmp):", filename$
                IF filename$ = "" THEN EXIT DO
                        GOSUB OpenFile
                IF of = 0 THEN CLOSE : rerr = 1: GOSUB ErrorInfo: GOTO main
                        GOSUB CheckBmp
                IF check = 0 THEN CLOSE : rerr = 2: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadBit
                        GOSUB ReadColor
                IF colo = 0 THEN CLOSE : rerr = 3: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadWH
                IF w = 0 THEN CLOSE : rerr = 4: GOSUB ErrorInfo: GOTO main
                IF h = 0 THEN CLOSE : rerr = 5: GOSUB ErrorInfo: GOTO main
                        GOSUB zip
                IF zip = 1 THEN CLOSE : rerr = 6: GOSUB ErrorInfo: GOTO main
                        GOSUB ReadPalette
                IF bit = 8 THEN SCREEN 13 ELSE SCREEN 12
                        GOSUB SetPalette
                        GOSUB ViewPicture
                        GOSUB AscKey
lop:
                GOSUB Last
        LOOP
        CLS
END

First:
        DIM pixel(8) AS INTEGER: x = 0: y = 1
        filename$ = ""
        of = 0: check = 0: colo = 0: wite = 0: high = 0: done = 0: change = 0
        xb = 1: yb = 1: full = 0
        OUT &H3C6, 255
        RANDOMIZE TIMER
        'FILES "*.bmp"
        'PRINT
RETURN

Last:
        ERASE pixel
        CLOSE #1
        SCREEN 12
        typ = 0
        CLS
RETURN

OpenFile: '(filename$|of)
        IF filename$ = "h" OR filename$ = "H" THEN GOTO Help
        a$ = RIGHT$(filename$, 1)
        n = LEN(filename$)
        ture = 1: pot = 0: pat = 0
        FOR i = 1 TO n
                a$ = RIGHT$(LEFT$(filename$, i), 1)
                IF a$ = "*" OR a$ = "+" OR a$ = "=" OR a$ = "<" OR a$ = ">" OR a$ = "[" OR a$ = "]" OR a$ = ";" OR a$ = CHR$(34) OR a$ = "?" OR a$ = "|" THEN ture = 0: EXIT FOR
                IF a$ = "/" AND i <> n THEN ture = 0
                IF a$ = "." AND i = 1 THEN ture = 0
                IF a$ = "." THEN pot = pot + 1
        NEXT

我来回复

您尚未登录,请登录后再回复。点此登录或注册