显示无格式256灰度级图象 

北 京 东 城 区 炮 局 胡 同 
冯 才 刚 
---- 在 具 体 应 用 中 可 能 会 要 处 理 无 格 式 的 图 像, 在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: