显示无格式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:

[返回]

首页 | 设为首页 | 加入收藏 | 关于本站 | 友情链接 | 版权声明