如何在VB中直接显示无格式256灰度级图像

来源： 作者： 出处：巧巧读书 2006-09-14 进入讨论组

• 关 键 词：

　　---- 在 具 体 应 用 中 可 能 会 要 处 理 无 格 式 的 图 像, 在VB 中 可 利 用API 函 数SetDIBitsToDevice 实 现 这 一 功 能. 下 面 是 我 在 工 作 中 用 到 的 显 示256X256 大 小,256 灰 度 级 图 像 的 程 序.

Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long

Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal HDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long

Type rgbquad

rgbBlue As Byte

rgbGreen As Byte

rgbRed As Byte

rgbReserved As Byte

End Type

Type PALETTEENTRY

peRed As Byte

peGreen As Byte

peBlue As Byte

peFlags As Byte

End Type

Type BITMAPFILEHEADER

bfType As Integer

bfSize As Long

bfReserved1 As Integer

bfReserved2 As Integer

bfOffBits As Long

End Type

Type BITMAPINFOHEADER

biSize As Long

biWidth As Long

biHeight As Long

biPlanes As Integer

biBitCount As Integer

biCompression As Long

biSizeImage As Long

biXPelsPerMeter As Long

biYPelsPerMeter As Long

biClrUsed As Long

biClrImportant As Long

End Type

Type BITMAPINFO

bmiHeader As BITMAPINFOHEADER

bmiColors(0 To 255) As rgbquad

End Type

Global Const SRCCOPY = &HCC0020 ' dest=source

Global Const srcand = &H8800C6 ' dest=source and dest

Global Const srcor = &HEE0086 ' dest=source or dest

Public Const COLORONCOLOR = 3

Public Const DIB_RGB_COLORS = 0 ' color table in RGBs

Public Const DIB_PAL_COLORS = 1 '

color table in palette indices

Global Const GMEM_MOVEABLE = &H2

'--------以上为定义部分,可放在一个BAS文件中--------

Dim x As Long, ii As Integer

Dim w1 As Long, h1 As Long

Dim bitmapinfo_h As BITMAPINFOHEADER,

bitmapfile_h As BITMAPFILEHEADER

Dim lpInitInfo As BITMAPINFO

Dim t_rgbquad(0 To 255) As rgbquad

Dim pLogPal As LOGPALETTE

Dim leng As Long

Dim t_buf() As Byte '图像数据buffer

On Error GoTo Error_process

'Set up error handler.

' Open the file

pfile1$ = "c:\fcg\test.d"

' test.d为256X256大小,256灰度级的无格式图像文件

fd% = FreeFile

w1 = 256 '图像宽度

h1 = 256 '图像高度

leng = w1 * h1

ReDim t_buf(leng) As Byte

Open pfile1$ For Binary As #fd%

Get #fd%, , t_buf

Close ' Close the file

leng = w1 * h1

bitmapfile_h.bfType = 19778 '"BM"

bitmapfile_h.bfSize = 1078 + h1 * w1

bitmapfile_h.bfReserved1 = 0

bitmapfile_h.bfReserved2 = 0

bitmapfile_h.bfOffBits = 1078

bitmapinfo_h.biSize = 40

bitmapinfo_h.biWidth = w1

bitmapinfo_h.biHeight = h1

bitmapinfo_h.biPlanes = 1

bitmapinfo_h.biBitCount = 8

bitmapinfo_h.biCompression = 0

bitmapinfo_h.biSizeImage = 0

bitmapinfo_h.biXPelsPerMeter = 0

bitmapinfo_h.biYPelsPerMeter = 0

bitmapinfo_h.biClrUsed = 256

For ii = 0 To 255 '设置色表为256灰度

t_rgbquad(ii).rgbBlue = CByte(ii)

t_rgbquad(ii).rgbGreen = CByte(ii)

t_rgbquad(ii).rgbRed = CByte(ii)

' t_rgbquad.rgbReserved = 0

Next ii

lpInitInfo.bmiHeader = bitmapinfo_h

For ii = 0 To 255

lpInitInfo.bmiColors(ii) = t_rgbquad(ii)

Next ii

'picture1为一个picture控件,

用于显示无格式256灰度级图像

x = SetDIBitsToDevice(picture1.HDC, 0, 0,

w1, h1, 0, 0, 0, h1, t_buf(0), lpInitInfo,

0) '显示图像

x = GlobalUnlock(hPal) '释放资源

x = GlobalFree(hPal)

GoTo Normal_exit

Error_process:

Msgbox "程序运行出错!"

Normal_exit:请保留地址 http://www.qqread.com/vb/s236205.html 更多内容请看VB图形图像编程专题，或进入讨论组讨论。

【收藏此文】【大 中 小】【打印】【关闭】

较早的文章：如何在VB中用API获得EXE文件图标并显示在Picture控件里

较新的文章：如何在VB中终止Windows系统