为什么?先看看这个Option ExplicitPrivate 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 BITMAPINFOHEADER, _ ByVal wUsage As Long) As LongPrivate Type BITMAPFILEHEADER '14 bytes bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End TypePrivate Type BITMAPINFOHEADER '40 bytes 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 TypePrivate Const BMPMagicCookie = &H4D42Private Sub BitBltFromDisk(ByVal dc As Long, ByVal FileName As String) Dim fiHeader As BITMAPFILEHEADER Dim bmHeader As BITMAPINFOHEADER Dim FNum As Integer Dim ScanLine As Long Dim DIBData() As Byte
'Either change this path to another uncompressed 24-bit bitmap or download ' the example bitmaps from my site and put them in your "C:\" directory
If Dir(FileName) = "" Then 'Check the file exists MsgBox "File; """ & FileName & """ not found!" Exit Sub End If
FNum = FreeFile Open FileName For Binary As #FNum 'Read the file header Get #FNum, , fiHeader
If fiHeader.bfType <> BMPMagicCookie Then MsgBox "This doesn't look like a valid bitmap file!" Close #FNum 'Close file and quit Exit Sub End If
'Read the bitmap header Get #FNum, , bmHeader
With bmHeader 'Check format If .biBitCount <> 24 Or .biCompression <> 0 Then MsgBox "This type of bitmap are not currently supported..." Close #FNum 'Close file and quit Exit Sub End If
'Calculate DWord aligned scanline length and read in bitmap data ScanLine = (((.biWidth * (.biBitCount / 8)) + 7) \ 4) * 4 ReDim DIBData(ScanLine - 1, .biHeight - 1) As Byte Get #FNum, , DIBData()
'Set up form and draw If SetDIBitsToDevice(hdc, 0, 0, .biWidth, .biHeight, _ 0, 0, 0, .biHeight, DIBData(0, 0), bmHeader, 0) = 0 Then _ MsgBox "Error drawing bitmap data!" End With Close #FNumEnd SubPrivate Sub Command1_Click() BitBltFromDisk Me.hdc, "d:\desktop\ctrla.bmp" End Sub
(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 BITMAPINFOHEADER, _
ByVal wUsage As Long) As LongPrivate Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End TypePrivate Type BITMAPINFOHEADER '40 bytes
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 TypePrivate Const BMPMagicCookie = &H4D42Private Sub BitBltFromDisk(ByVal dc As Long, ByVal FileName As String)
Dim fiHeader As BITMAPFILEHEADER
Dim bmHeader As BITMAPINFOHEADER
Dim FNum As Integer
Dim ScanLine As Long
Dim DIBData() As Byte
'Either change this path to another uncompressed 24-bit bitmap or download
' the example bitmaps from my site and put them in your "C:\" directory
If Dir(FileName) = "" Then 'Check the file exists
MsgBox "File; """ & FileName & """ not found!"
Exit Sub
End If
FNum = FreeFile
Open FileName For Binary As #FNum
'Read the file header
Get #FNum, , fiHeader
If fiHeader.bfType <> BMPMagicCookie Then
MsgBox "This doesn't look like a valid bitmap file!"
Close #FNum 'Close file and quit
Exit Sub
End If
'Read the bitmap header
Get #FNum, , bmHeader
With bmHeader
'Check format
If .biBitCount <> 24 Or .biCompression <> 0 Then
MsgBox "This type of bitmap are not currently supported..."
Close #FNum 'Close file and quit
Exit Sub
End If
'Calculate DWord aligned scanline length and read in bitmap data
ScanLine = (((.biWidth * (.biBitCount / 8)) + 7) \ 4) * 4
ReDim DIBData(ScanLine - 1, .biHeight - 1) As Byte
Get #FNum, , DIBData()
'Set up form and draw
If SetDIBitsToDevice(hdc, 0, 0, .biWidth, .biHeight, _
0, 0, 0, .biHeight, DIBData(0, 0), bmHeader, 0) = 0 Then _
MsgBox "Error drawing bitmap data!"
End With
Close #FNumEnd SubPrivate Sub Command1_Click()
BitBltFromDisk Me.hdc, "d:\desktop\ctrla.bmp"
End Sub