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

Public Function BitMapApplicIsBitMap(ByRef pBitMapApplic As tpBitMapApplic) As Boolean
'BitMapApplicIsBitMap函数
'语法：[tOutBool]=BitMapApplicIsBitMap(pBitMapApplic)
'功能：判断一个BitMapApplic是否有效
'参数：tpBitMapApplic pBitMapApplic 必要参数。有效文件名
'返回：Boolean tOutBool 逻辑值。如pBitMapApplic有效则为真。
'说明：本函数仅接受24bit位图。
Dim tOutBool As Boolean

With pBitMapApplic.bmaHeader
tOutBool = (.bhFileHeader.bfType = &H4D42) And (.bhInfoHeader.biBitCount = 24)
End With

BitMapApplicIsBitMap = tOutBool
End Function

Public Function BitMapApplicPutToFile(ByVal pFileName As String, ByRef pBitMapApplic As tpBitMapApplic) As Long
'BitMapApplicPutToFile函数
'语法：[tOutLength]=BitMapApplicPutToFile(pFileName, pBitMapApplic)
'功能：将一个BitMapApplic存储到文件中。
'参数：string pFileName 必要参数。有效文件名
' tpBitMapApplic pBitMapApplic 必要参数。位图的BitMapApplic
'返回：long tOutLength 位图文件的长度
'说明：本函数并不检测BMP文件是否是正确的格式，仅接受24bit位图。

Dim tOutLength As Long

Dim tBitMapHeader As tpBitMapHeader

Dim tBytes() As Byte
Dim tBytesCount As Long

Dim tFileNumber As Integer

Dim tOffBits As Long

tFileNumber = FreeFile

tBitMapHeader = pBitMapApplic.bmaHeader
tBytes() = pBitMapApplic.bmaBytes

tOffBits = tBitMapHeader.bhFileHeader.bfOffBits

Open pFileName For Binary As #tFileNumber

Put #tFileNumber, 1, tBitMapHeader
Put #tFileNumber, tOffBits + 1, tBytes()

tOutLength = LOF(tFileNumber)
Close #tFileNumber

BitMapApplicPutToFile = tOutLength

End Function

Public Function BitMapApplicGetByFile(ByVal pFileName As String) As tpBitMapApplic
'BitMapApplicGetByFile函数
'语法：[tOutBitMapApplic]=BitMapApplicGetByFile(pFileName)
'功能：从文件中获得一个BitMapApplic
'参数：string pFileName 必要参数。有效文件名
'返回：tpBitMapApplic tOutBitMapApplic
'说明：本函数并不检测BMP文件是否是正确的格式，仅接受24bit位图。
Dim tOutBitMapApplic As tpBitMapApplic

Dim tBitMapHeader As tpBitMapHeader

Dim tBytes() As Byte
Dim tBytesCount As Long

Dim tFileNumber As Integer

Dim tOffBits As Long

tFileNumber = FreeFile

Open pFileName For Binary As #tFileNumber

Get #tFileNumber, 1, tBitMapHeader

With tBitMapHeader
tOffBits = .bhFileHeader.bfOffBits
.bhInfoHeader.biWidth = .bhInfoHeader.biWidth + (CBool(.bhInfoHeader.biWidth Mod 2) And 1)
tBytesCount = .bhInfoHeader.biWidth * .bhInfoHeader.biHeight * .bhInfoHeader.biBitCount \ 8
End With

ReDim tBytes(tBytesCount - 1)

Get #tFileNumber, tOffBits + 1, tBytes()

Close #tFileNumber

With tOutBitMapApplic

.bmaHeader = tBitMapHeader
.bmaBytes = tBytes()

End With

BitMapApplicGetByFile = tOutBitMapApplic

End Function

'[Pixels]

Function PixelsShow(ByRef pPixels() As tpPixelRGB24, pBitMapInfo As tpBitMapInfo)

End Function

Function PixelsGetByBytes(ByRef pBytes() As Byte) As tpPixelRGB24()
'PixelsGetByBytes函数
'语法：[tOutPixels()]=PixelsGetByBytes(pBytes())
'功能：将Byte数组表示的位图数据转换成tpPixelRGB24数组。
'参数：byte pBytes() 必要参数。包含有位图数据的Byte数组
'返回：tpPixelRGB24 tOutPixels() 必要参数。包含有位图数据的tpPixelRGB24数组
Dim tOutPixels() As tpPixelRGB24
Dim tOutPixelsLength As Long
Dim tBytesLength As Long

tBytesLength = UBound(pBytes) + 1

tOutPixelsLength = tBytesLength \ 3

ReDim tOutPixels(tOutPixelsLength - 1)

CopyMemory tOutPixels(0), pBytes(0), tBytesLength

PixelsGetByBytes = tOutPixels()
End Function

Function PixelGetBySet(ByVal pRed As Byte, ByVal pGreen As Byte, ByVal pBlue As Byte) As tpPixelRGB24
Dim tOutPixel As tpPixelRGB24

With tOutPixel
.rgbBlue = pBlue
.rgbGreen = pGreen
.rgbRed = pRed
End With

PixelGetBySet = tOutPixel
End Function

Function PixelAlphaMix(ByRef pBackPix As tpPixelRGB24, ByRef pOverPix As tpPixelRGB24, ByVal pAlpha As Byte, Optional ByVal pAlphaLevel As Byte = 100) As tpPixelRGB24
Dim tOutPixel As tpPixelRGB24

With tOutPixel
.rgbBlue = ByteLayersAlphaMix(pBackPix.rgbBlue, pOverPix.rgbBlue, pAlpha, pAlphaLevel)
.rgbGreen = ByteLayersAlphaMix(pBackPix.rgbGreen, pOverPix.rgbGreen, pAlpha, pAlphaLevel)
.rgbRed = ByteLayersAlphaMix(pBackPix.rgbRed, pOverPix.rgbRed, pAlpha, pAlphaLevel)
End With

PixelAlphaMix = tOutPixel
End Function

Function PixelGetByPixels(ByVal pX As Long, ByVal pY As Long, pPixels() As tpPixelRGB24, pBitMapInfoHeader As tpBitMapInfoHeader) As tpPixelRGB24
Dim tBytesIndex As Long
Dim tPixelIndex As Long
Dim tX As Long
Dim tY As Long
Dim tWidth As Long
Dim tHeight As Long

With pBitMapInfoHeader
tWidth = .biWidth
tHeight = .biHeight
End With

tX = pX Mod tWidth
tY = tHeight - (pY Mod tHeight) - 1

tPixelIndex = tY * tWidth + tX

PixelGetByPixels = pPixels(tPixelIndex)
End Function


Function PixelSetToPixels(ByVal pX As Long, ByVal pY As Long, pPixels() As tpPixelRGB24, pBitMapInfoHeader As tpBitMapInfoHeader, pPixel As tpPixelRGB24)
Dim tBytesIndex As Long
Dim tPixelIndex As Long
Dim tX As Long
Dim tY As Long
Dim tWidth As Long
Dim tHeight As Long

With pBitMapInfoHeader
tWidth = .biWidth
tHeight = .biHeight
End With

tX = pX Mod tWidth
tY = tHeight - (pY Mod tHeight) - 1

tPixelIndex = tY * tWidth + tX

pPixels(tPixelIndex) = pPixel
End Function

'[Bytes]

查看本文来源