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

窗体部分

Dim N As tpBitMapApplic
Dim SPX() As tpPixelRGB24

Dim pubBitMapApplic As tpBitMapApplic
Dim pubPixels() As tpPixelRGB24
Dim pubBytes() As Byte
Dim pubBitMapInfo As tpBitMapInfo
Dim pubBitMapInfoHeader As tpBitMapInfoHeader

Dim pubX() As Long
Dim pubY() As Long
Dim pubZ() As Long
Dim pubRainLength As Long

Dim pubWorking As Boolean

Dim pubAutoLength As Boolean

Dim pubShowButtom As Boolean

Private Sub Command3_Click()
pubAutoLength = Not pubAutoLength
End Sub

Private Sub Command1_Click()
Dim tLoop As Long
Dim tPixels() As tpPixelRGB24
Dim tPixel As tpPixelRGB24
Dim tLineLong As Long
Dim tDoTimer As Long
pubWorking = True
Command1.Enabled = False
Do
tDoTimer = Timer * 100
tPixels() = pubPixels()
tPixel = PixelGetBySet(255, 255, 255)
For tLoop = 0 To pubRainLength
pubY(tLoop) = pubY(tLoop) + pubZ(tLoop) + 20
If pubY(tLoop) > pubBitMapInfoHeader.biHeight Then
pubX(tLoop) = Int(Rnd * pubBitMapInfoHeader.biWidth)
pubZ(tLoop) = Int(Rnd * 100)
pubY(tLoop) = 0 - (pubZ(tLoop) * 2) + Int(Rnd * 20)
End If
RainDraw pubX(tLoop), pubY(tLoop), tPixels(), pubBitMapInfo, (pubZ(tLoop) \ 2) + 10, tPixel, CByte(pubZ(tLoop) \ 2)
Next
'StretchDIBits Form_Test.hDC, 0, 0, pubBitMapInfoHeader.biWidth, pubBitMapInfoHeader.biHeight, 0, 0, pubBitMapInfoHeader.biWidth, pubBitMapInfoHeader.biHeight, tPixels(0), pubBitMapInfo, 0, &HCC0020
StretchDIBits Form_Test.hDC, 0, 0, Form_Test.ScaleWidth, Form_Test.ScaleHeight, 0, 0, pubBitMapInfoHeader.biWidth, pubBitMapInfoHeader.biHeight, tPixels(0), pubBitMapInfo, 0, &HCC0020
DoEvents
'If (Timer * 100) - tDoTimer > 10 And pubAutoLength And pubRainLength > 10 Then HScroll1.Value = HScroll1.Value - 1
Loop While pubWorking
Command1.Enabled = True
End Sub

Private Sub Command2_Click()
pubWorking = False
End Sub

Private Sub Form_DblClick()
pubShowButtom = Not pubShowButtom
Command1.Visible = pubShowButtom
Command2.Visible = pubShowButtom
Text1.Visible = pubShowButtom
HScroll1.Visible = pubShowButtom
End Sub

Private Sub Form_Load()
pubRainLength = 400
ReDim pubX(pubRainLength)
ReDim pubY(pubRainLength)
ReDim pubZ(pubRainLength)
HScroll1.Max = pubRainLength
HScroll1.Value = pubRainLength \ 2
pubBitMapApplic = BitMapApplicGetByFile("Test.bmp")
'pubBitMapApplic.bmaHeader.bhInfoHeader.biWidth = pubBitMapApplic.bmaHeader.bhInfoHeader.biWidth + (CBool(pubBitMapApplic.bmaHeader.bhInfoHeader.biWidth Mod 4) And 1)
pubBytes() = pubBitMapApplic.bmaBytes
pubPixels() = PixelsGetByBytes(pubBytes())
pubBitMapInfo = BitMapInfoGetByBitMapApplic(pubBitMapApplic)
pubBitMapInfoHeader = pubBitMapApplic.bmaHeader.bhInfoHeader
Text1.Text = pubBitMapInfoHeader.biWidth
End Sub

Sub GY(pX, pY)
Dim tN As tpBitMapApplic
Dim tR As Long
Dim tX As Long
Dim tY As Long
Dim tL As Long
Dim tCol As Long
Dim SYBI() As Byte
Dim SYPX() As tpPixelRGB24
Dim BH As tpBitMapInfoHeader
Dim BN As tpBitMapInfo

tN = N

SYPX() = SPX()

BN = BitMapInfoGetByBitMapApplic(tN)
tR = 50
Dim tPix As tpPixelRGB24
BH = N.bmaHeader.bhInfoHeader

'SYBI() = N.bmaBytes
'SYPX() = PixelsGetByBytes(SYBI())

For tX = pX - tR To pX + tR
For tY = pY - tR To pY + tR
tL = tR - Sqr(Abs(tX - pX) ^ 2 + Abs(tY - pY) ^ 2)
If tL < 0 Then tL = 0
tCol = (tL * 100) \ tR
If tX > 0 And tY > 0 Then tPix = PixelGetByPixels(tX, tY, SYPX(), BH)
tPix.rgbGreen = ByteLayersAlphaMix(tPix.rgbGreen, 255, CByte(tCol)) '(255 * tCol) / 255 + (tPix.rgbGreen * (255 - tCol) / 255)
If tX > 0 And tY > 0 Then PixelSetToPixels tX, tY, SYPX(), BH, tPix
Next
Next

StretchDIBits Form_Test.hDC, 0, 0, BH.biWidth, BH.biHeight, 0, 0, BH.biWidth, BH.biHeight, SYPX(0), BN, 0, &HCC0020

'tN.bmaBytes = BytesGetByPixels(SYPX())
'BitMapApplicShow Form_Test.hDC, tN
End Sub

Private Sub Form_Unload(Cancel As Integer)
pubWorking = False
End
End Sub

Private Sub HScroll1_Change()
pubRainLength = HScroll1.Value
Text1.Text = pubRainLength
End Sub

查看本文来源