网球

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

2019-09-11 14:19:02来源:励志吧0次阅读

模块部分

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

查看本文来源

小孩中暑的症状
小孩睡觉流鼻血
宝宝消化不良怎么办
小儿便秘
分享到: