VB 6 把彩色图片变成灰阶的方法

Option Explicit
'算法二要的API
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
'算法一要的API
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long

'算法二 提高速度约2秒  是方法1的46倍速度
Public Function TurnBmp(hSrcBmp As Long, Optional hDestBmp As Long = 0) As Boolean
Dim x  As Long, Y As Long
Dim BytesPixel As Long
If hDestBmp = 0 Then hDestBmp = hSrcBmp
Dim tSBmpInfo As BITMAP, tDBmpInfo As BITMAP
Dim sBits() As Byte, dBits() As Byte
'获得位图信息
Call GetObject(hSrcBmp, Len(tSBmpInfo), tSBmpInfo)
Call GetObject(hDestBmp, Len(tDBmpInfo), tDBmpInfo)
'申请空间
ReDim sBits(1 To tSBmpInfo.bmWidthBytes, 1 To tSBmpInfo.bmHeight)
ReDim dBits(1 To tDBmpInfo.bmWidthBytes, 1 To tDBmpInfo.bmHeight)
'获得源图与目标图二进制位
Call GetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
Call GetBitmapBits(hDestBmp, tDBmpInfo.bmWidthBytes * tDBmpInfo.bmHeight, dBits(1, 1))
'计算颜色值占用多少字节
BytesPixel = tSBmpInfo.bmBitsPixel / 8
Dim l As Integer
Dim b As Long
'旋转
For Y = 1 To tSBmpInfo.bmHeight
For x = 1 To tSBmpInfo.bmWidth
b = (x - 1) * BytesPixel + 1
l = sBits(b, Y) * 0.114 + sBits(b + 1, Y) * 0.587 + sBits(b + 2, Y) * 0.299
dBits(b, Y) = l
dBits(b + 1, Y) = l
dBits(b + 2, Y) = l
'l = dBits((x - 1) * BytesPixel + 1, Y) * 0.114 + dBits((x - 1) * BytesPixel + 2, Y) * 0.587 + dBits((x - 1) * BytesPixel + 3, Y) * 0.299
'dBits((x - 1) * BytesPixel + 1, Y) = l
'dBits((x - 1) * BytesPixel + 2, Y) = l
'dBits((x - 1) * BytesPixel + 3, Y) = l
Next x
Next Y
Call SetBitmapBits(hDestBmp, tDBmpInfo.bmWidthBytes * tDBmpInfo.bmHeight, dBits(1, 1))
End Function

'算法2.2 提高速度约2秒  是方法1的46倍速度  参数不一样
Public Function TurnPicGray(hSrcBmp As Long) As Boolean
Dim x  As Long, Y As Long
Dim BytesPixel As Long
Dim tSBmpInfo As BITMAP
Dim sBits() As Byte
'获得位图信息
Call GetObject(hSrcBmp, Len(tSBmpInfo), tSBmpInfo)
'申请空间
ReDim sBits(1 To tSBmpInfo.bmWidthBytes, 1 To tSBmpInfo.bmHeight)
'获得源图与目标图二进制位
Call GetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
'计算颜色值占用多少字节
BytesPixel = tSBmpInfo.bmBitsPixel / 8
Dim l As Integer
Dim b As Long
'旋转
For Y = 1 To tSBmpInfo.bmHeight
For x = 1 To tSBmpInfo.bmWidth
b = (x - 1) * BytesPixel + 1
l = sBits(b, Y) * 0.114 + sBits(b + 1, Y) * 0.587 + sBits(b + 2, Y) * 0.299
sBits(b, Y) = l
sBits(b + 1, Y) = l
sBits(b + 2, Y) = l
Next x
Next Y
Call SetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
End Function

'算法一
Public Sub SetPicGray(Pic As PictureBox)
Dim width5       As Long, heigh5       As Long, rgb5       As Long
Dim hdc5     As Long, i       As Long, j       As Long
Dim bBlue     As Long, bRed       As Long, bGreen       As Long
Dim Y     As Long
Pic.AutoRedraw = True
Pic.ScaleMode = 3
width5 = Pic.ScaleWidth
heigh5 = Pic.ScaleHeight
hdc5 = Pic.hdc
For i = 1 To width5
For j = 1 To heigh5
rgb5 = GetPixel(hdc5, i, j)   'API提高速度 约1秒
' rgb5 = Pic.Point(i, j)
bBlue = (rgb5 / &H10000) And &HFF     '获得兰色值
bRed = rgb5 And &HFF                  '获得红色值
bGreen = (rgb5 / &H100) And &HFF      '获得绿色值
'将三原色转换为灰度
Y = (9798 * bRed + 19235 * bGreen + 3735 * bBlue) / 32768
'将灰度转换为RGB
rgb5 = RGB(Y, Y, Y)
SetPixelV hdc5, i, j, rgb5    'API提高速度 约1秒
'Pic.PSet (i, j), rgb5
Next j
Next i
Set Pic.Picture = Pic.Image
End Sub

Private Sub Command1_Click()
Dim l As Double
Command1.Enabled = False
Picture1.Picture = Picture2.Picture
Picture1.Refresh
l = Timer
Call SetPicGray(Picture1)

Label1 = "GetPixel速度      " & Format(Abs(l - Timer), "0.000000") & "秒"
Picture1.Refresh
Command1.Enabled = True
End Sub

Private Sub Command2_Click()
Dim l As Double
Command2.Enabled = False
Picture1.Picture = Picture2.Picture
Picture1.Refresh
l = Timer
Call TurnPicGray(Picture1.Picture.Handle)

Label2 = "GetBitmapBits速度 " & Format(Abs(l - Timer), "0.000000") & "秒"
Picture1.Refresh
Command2.Enabled = True
End Sub

Private Sub Form_Load()

End Sub