窗体部分

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

模块部分

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
biComdivssion 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
.biComdivssion = 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

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]

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

Dim tPixelsLength As Long

tPixelsLength = UBound(pPixels) + 1

tOutBytesLength = tPixelsLength * 3

ReDim tOutBytes(tOutBytesLength - 1)

CopyMemory tOutBytes(0), pPixels(0), tOutBytesLength

BytesGetByPixels = tOutBytes()
End Function

Function ByteLayersAlphaMix(pBackValue As Byte, pOverValue As Byte, pAlpha As Byte, Optional pAlphaLevel As Byte = 100) As Byte
'ByteLayersAlphaMix函数
'语法：[tOutByte]=ByteLayersAlphaMix(pBackValue, pOverValue, pAlpha, [pAlphaLevel])
'功能：将两个Byte类型的值进行Alpha混合运算，此函数是对像素进行Alpha混合的基础函数。
'参数：byte pBackValue 必要参数。做底色的亮度数据。
' byte pOverValue 必要参数。做覆盖色的亮度数据。
' byte pAlpha 必要参数。覆盖色的Alpha透明度，须对应pAlphaLevel的规定。
' byte pAlphaLevel 可选参数。Alpha的透明度级别，最大可到255。
'返回：byte tOutByte 混合后的Byte数据
Dim tOutByte As Byte

Dim tBackAlpha As Long
Dim tMixValue As Long

tBackAlpha = Abs(pAlphaLevel - pAlpha)

tMixValue = (CLng(pBackValue) * tBackAlpha + CLng(pOverValue) * CLng(pAlpha)) \ CLng(pAlphaLevel)

tOutByte = tMixValue Mod 256

ByteLayersAlphaMix = tOutByte
End Function


'[Other]

Function PixelSetToBitMapApplic(ByVal pX As Long, ByVal pY As Long, pBytes() As Byte, 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 = pY Mod tHeight

tPixelIndex = tY * tWidth + tX
tBytesIndex = tPixelIndex * 3

With pPixel
pBytes(tBytesIndex) = .rgbBlue
pBytes(tBytesIndex + 1) = .rgbGreen
pBytes(tBytesIndex + 2) = .rgbRed
End With

'Form_Test.Text1.Text = tBytesIndex
End Function

Function PixelGetByBitMapApplic(ByVal pX As Long, ByVal pY As Long, pBitMapApplic As tpBitMapApplic) As tpPixelRGB24
Dim tOutPixel As tpPixelRGB24
Dim tBytes() As Byte
Dim tBytesIndex As Long
Dim tPixelIndex As Long
Dim tX As Long
Dim tY As Long
Dim tWidth As Long
Dim tHeight As Long

tBytes() = pBitMapApplic.bmaBytes

With pBitMapApplic.bmaHeader.bhInfoHeader
tWidth = .biWidth
tHeight = .biHeight
End With

tX = pX Mod tWidth
tY = pY Mod tHeight

tPixelIndex = tY * tHeight + tX
tBytesIndex = tPixelIndex * 3

With tOutPixel
.rgbBlue = tBytes(tBytesIndex)
.rgbGreen = tBytes(tBytesIndex + 1)
.rgbRed = tBytes(tBytesIndex + 2)
End With

PixelGetByBitMapApplic = tOutPixel
End Function

Function BytesAddLandBlur(pBytes As Variant, pLandWidth As Integer) As Byte()
Dim tLoop As Long

Dim tBytesSur() As Byte
Dim tBytesDes() As Byte

Dim tLoopOn As Long
Dim tLoopEnd As Long

Dim tIndex As Long
Dim tIndexB As Long
Dim tIndexP As Long

Dim tPixByte(2) As Long

tBytesSur() = pBytes
tBytesDes() = pBytes

tLoopOn = LBound(tBytesIn)
tLoopEnd = UBound(tBytesIn)

Form_Test.Text1.Text = ((tLoopEnd - tLoopOn) + 1) Mod 3

For tLoop = tLoopOn To tLoopEnd
tIndex = tLoop * 3
tIndexB = (tLoop - 1) * 3
tIndexP = (tLoop + 1) * 3
tB1 = (CLng(tBytesIn(tIndex)) + CLng(tBytesIn(tIndexB)) + CLng(tBytesIn(tIndexP))) \ 3
tB2 = (CLng(tBytesIn(tIndex + 1)) + CLng(tBytesIn(tIndexB + 1)) + CLng(tBytesIn(tIndexP + 1))) \ 3
tB3 = (CLng(tBytesIn(tIndex + 2)) + CLng(tBytesIn(tIndexB + 2)) + CLng(tBytesIn(tIndexP + 2))) \ 3
Next

BytesAddLandBlur = tBytesOut
End Function

Function ValueSetDefault(ByVal pValue As Long, ByVal pDefValue As Long) As Long
Dim tOutLong As Long

tOutLong = pValue + (pDefValue And (Not CBool(pValue)))

ValueSetDefault = tOutLong
End Function

Function RainDraw(pX As Long, pY As Long, pPixels() As tpPixelRGB24, pBitMapInfo As tpBitMapInfo, pLineLong As Long, pColorPixel As tpPixelRGB24, Optional pAlpha As Byte = 100)
Dim tLoop As Long
Dim tY As Long
Dim tPixel As tpPixelRGB24
Dim tBackPixel As tpPixelRGB24
Dim tAlpha As Byte
Dim tBitMapInfoHeader As tpBitMapInfoHeader
tBitMapInfoHeader = pBitMapInfo.bmiHeader

For tLoop = -pLineLong To pLineLong
tY = pY + tLoop
If tY < tBitMapInfoHeader.biHeight And tY >= 0 Then
tAlpha = (100 * (pLineLong - Abs(tLoop)) * pAlpha) \ pLineLong * 100
tBackPixel = PixelGetByPixels(pX, tY, pPixels(), tBitMapInfoHeader)
tPixel = PixelAlphaMix(tBackPixel, pColorPixel, tAlpha)
PixelSetToPixels pX, tY, pPixels(), tBitMapInfoHeader, tPixel
End If
Next
End Function

本文来源：http://blog.csdn.net/KiteGirl/archive/2007/07/11/1684894.aspx