VB6下的BitMap示例：模拟雨点程序(二)

模块部分

Public Type tpBitMapFileHeader
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Public Type tpBitMapInfoHeader
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

Public Type tpRGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Public Type tpPixelRGB24
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
End Type

Public Type tpPixelRGB32
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte
End Type

Public Type tpBitMapHeader
bhFileHeader As tpBitMapFileHeader
bhInfoHeader As tpBitMapInfoHeader
End Type

Public Type tpBitMapInfo
bmiHeader As tpBitMapInfoHeader
bmiColors As tpRGBQuad
End Type

Public Type tpBitMapApplic
bmaHeader As tpBitMapHeader
bmaBytes As Variant
End Type

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function StretchDIBits 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 wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As tpBitMapInfo, ByVal wUsage As Long, ByVal dwRop As Long) As Long

Public Const DIB_PAL_COLORS = 1

Public Const DIB_RGB_COLORS = 0

Public Const SRCCOPY = &HCC0020


Function BitMapGetByBytes(ByRef pBytes() As Byte, Optional ByVal pWidth As Long = 800) As tpBitMapHeader
Dim tOutAny As tpBitMapHeader

Dim tOffByte As Long

tOffByte = UBound(pBytes)

tOutAny = BitMapGetBySpace(pWidth)

With tOutAny.bhFileHeader
.bfSize = LenB(tOutAny) + tOffByte + 1
End With

With tOutAny.bhInfoHeader
.biHeight = tOffByte \ .biWidth \ 3
End With

BitMapGetByBytes = tOutAny
End Function

Function BitMapGetBySpace(Optional ByVal pWidth As Long = 800) As tpBitMapHeader
Dim tOutAny As tpBitMapHeader

With tOutAny.bhFileHeader
.bfType = &H4D42
.bfSize = LenB(tOutAny)
.bfReserved1 = 0
.bfReserved2 = 0
.bfOffBits = LenB(tOutAny)
End With

With tOutAny.bhInfoHeader
.biBitCount = 24
.biClrImportant = 0
.biClrUsed = 0
.biCompression = 0
.biHeight = 0
.biPlanes = 1
.biSize = 40
.biSizeImage = 0
.biWidth = pWidth
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
End With

BitMapGetBySpace = tOutAny
End Function

Function BytesGetByFile(ByVal pFileName As String) As Byte()
Dim tOutBytes() As Byte

Dim tFileNumber As Integer
Dim tOffByte As Long

tFileNumber = FreeFile

Open pFileName For Binary As #tFileNumber

tOffByte = LOF(tFileNumber) - 1
ReDim tOutBytes(tOffByte)

Get #tFileNumber, 1, tOutBytes()

Close #tFileNumber

BytesGetByFile = tOutBytes()
End Function

'Form_Test.Text1.Text = Hex(tBitMapHeader.bhFileHeader.bfType)

'[BitMapInfo]

Public Function BitMapInfoGetByBitMapApplic(ByRef pBitMapApplic As tpBitMapApplic) As tpBitMapInfo
Dim tOutBitMapInfo As tpBitMapInfo

With tOutBitMapInfo
.bmiHeader = pBitMapApplic.bmaHeader.bhInfoHeader
End With

BitMapInfoGetByBitMapApplic = tOutBitMapInfo
End Function

'[BitMapApplic]

Public Function BitMapApplicShow(ByVal pDC As Long, ByRef pBitMapApplic As tpBitMapApplic, Optional ByVal pTop As Long, Optional ByVal pLeft As Long, Optional ByVal pWidth As Long, Optional ByVal pHeight As Long) As Long
Dim tOutLong As Long

Dim tBitMapInfo As tpBitMapInfo
Dim tBytes() As Byte

Dim tDesTop As Long
Dim tDesLeft As Long
Dim tDesWidth As Long
Dim tDesHeight As Long

Dim tSurTop As Long
Dim tSurLeft As Long
Dim tSurWidth As Long
Dim tSurHeight As Long

tBitMapInfo = BitMapInfoGetByBitMapApplic(pBitMapApplic)
tBytes() = pBitMapApplic.bmaBytes

With tBitMapInfo.bmiHeader
tSurTop = 0
tSurLeft = 0
tSurWidth = .biWidth
tSurHeight = .biHeight
End With

tDesTop = ValueSetDefault(pTop, tSurTop)
tDesLeft = ValueSetDefault(pLeft, tSurLeft)
tDesWidth = ValueSetDefault(pWidth, tSurWidth)
tDesHeight = ValueSetDefault(pHeight, tSurHeight)

tOutLong = StretchDIBits(pDC, tDesLeft, tDesTop, tDesWidth, tDesHeight, tSurLeft, tSurTop, tSurWidth, tSurHeight, tBytes(0), tBitMapInfo, 0, &HCC0020)

BitMapApplicShow = tOutLong
End Function

查看本文来源