The fastest way to gray a picture .

[laviewpbt]

Fist ,Add a new class named "CImage",then copythe following codes and paste to it.


Option Explicit


Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Type BITMAPINFOHEADER
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

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

Private Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Reserved As Byte
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type


Private Const BI_bitfields = 3& '带掩码的
Private Const BI_RGB = 0 '正常
Private Const DIB_RGB_COLORS = 0 '真彩色
Private Const OBJ_BITMAP = 7 '位图对象
Private Const SRCCOPY = &HCC0020 '直接拷贝
Private Const IMAGE_BITMAP = 0 'LoadImage函数的载入类型，位图
Private Const LR_LOADFROMFILE = &H10 '从文件载入
Private Const LR_CREATEDIBSECTION = &H2000 '如果指定了IMAGE_BITMAP，就返回DIBSection的句柄，而不是位图的句柄
Private Const STRETCH_ANDSCANS = 1 '默认设置。剔除的线段与剩下的线段进行AND运算。这个模式通常应用于采用了白色背景的单色位 图
Private Const STRETCH_ORSCANS = 2 '剔除的线段被简单的清除。这个模式通常用于彩色位图
Private Const STRETCH_DELETESCANS = 3 '剔除的线段与剩下的线段进行OR运算。这个模式通常应用于采用了白色背景的单色位图
Private Const STRETCH_HALFTONE = 4 '目标位图上的像素块被设为源位图上大致近似的块。这个模式要明显慢于其他模式

'******************************************** 用于图像方面的相关API ********************************************

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long

'******************************************** 用于系统输出的相关API ********************************************

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long

'******************************************** 用于内存处理的相关API ********************************************

Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Declare Function VarPtrArray Lib "msvbvm50" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)


'******************************************** 公共常用的API函数 ********************************************

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long


Private mHdc As Long '保存了内存DC
Private mhDib As Long '当前DibSection的句柄
Private mhOldDib As Long '原始DibSection的句柄
Private mPtr As Long '当前DibSection的内存地址
Private mWidthBytes As Long '当前图像的扫描行字节数
Private mBmpInfo As BITMAPINFOHEADER '当前图像的文件信息


Private Sub Class_Terminate()
Destroy
End Sub

Public Property Get Width() As Long
Width = mBmpInfo.biWidth
End Property

Public Property Get Height() As Long
Height = mBmpInfo.biHeight
End Property

Public Property Get hdc() As Long
hdc = mHdc
End Property

Public Property Get DataPtr() As Long
DataPtr = mPtr
End Property

Public Property Get WidthBytes() As Long
WidthBytes = mWidthBytes
End Property




'************************************************* ****************************************
'** 函 数 名 ： CreateDib
'** 输 入 ： Width - DIB的宽度
' Height - DIB的高度
' Bits - 位图的位数，默认为32
'** 输 出 ： 返回是否创建成功
'** 功能描述 ： 创建新的DIB
'** 开发日期 ： 2008-5-19
'** 作 者 ： laviewpbt
'** 修改日期 ：
'** 版 本 ： Version 1.3.1
'************************************************* ***************************************

Private Function CreateDib(ByVal Width As Long, ByVal Height As Long, Optional ByVal Bits As Integer = 32) As Boolean
Dim i As Long
Destroy '销毁以前的DIB
mHdc = CreateCompatibleDC(0) '创建DIB设备场景
If mHdc <> 0 Then
With mBmpInfo '位图信息头
.biSize = Len(mBmpInfo)
.biPlanes = 1
.biBitCount = Bits
.biWidth = Width
.biHeight = Height
.biCompression = BI_RGB
Select Case Bits '保证每个扫描行必须是4的倍数
' Case 1
' mWidthBytes = (((.biWidth + 7) \ 8 + 3) And &HFFFFFFFC)
' Case 4
' mWidthBytes = (((.biWidth + 1) \ 2 + 3) And &HFFFFFFFC)
Case 8
mWidthBytes = ((.biWidth + 3) And &HFFFFFFFC)
' Case 16
' mWidthBytes = ((.biWidth * 2 + 3) And &HFFFFFFFC)
' Case 24
' mWidthBytes = ((.biWidth * 3 + 3) And &HFFFFFFFC)
Case 32
mWidthBytes = .biWidth * 4
Case Else
Exit Function
End Select
.biSizeImage = mWidthBytes * .biHeight
End With
mhDib = CreateDIBSection(mHdc, mBmpInfo, DIB_RGB_COLORS, mPtr, 0, 0) '创建DIB，mPtr就是指向这个创建的DIBSECTION的内存地址
If mhDib <> 0 Then
mhOldDib = SelectObject(mHdc, mhDib) '选入设备场景
If Bits = 8 Then '如果是8位，我们认为它是灰度图像，建立起调色板
ReDim ColorTable(0 To 255) As RGBQUAD
For i = 0 To 255
ColorTable(i).Red = i
ColorTable(i).Green = i
ColorTable(i).Blue = i
Next
SetDIBColorTable mHdc, 0, 256, ColorTable(0) '设置调色板数据
End If
CreateDib = True
End If
End If
End Function


Public Function LoadPictureFormFile(Filename As String) As Boolean
On Error Resume Next '防止LoadPicture加载不支持的图片文件或非图片文件时出错
Dim StdPic As StdPicture
Dim Width As Long, Height As Long
If Dir(Filename) <> "" Then
Set StdPic = LoadPicture(Filename)
If Not StdPic Is Nothing Then
Width = ConvertHimetrix2Pixels(StdPic.Width, True) 'StdPicture宽度中的单位是Himetrics
Height = ConvertHimetrix2Pixels(StdPic.Height, False)
If CreateDib(Width, Height, 32) = True Then '创建一个空白的Dib
StdPic.Render mHdc + 0, 0, 0, Width + 0, Height + 0, 0, StdPic.Height, StdPic.Width, -StdPic.Height, ByVal 0 '类似于BMP的逆序存储，所以用-StdPic.Height
End If
Set StdPic = Nothing
End If
End If
End Function


Public Function ChangeToGreyMode() As Boolean
Dim i As Long, j As Long
Dim DataArr(0 To 2) As Byte, pDataArr(0 To 0) As Long
Dim OldArrPtr As Long, OldpArrPtr As Long
Dim DataArrC(0 To 2) As Byte, pDataArrC(0 To 0) As Long
Dim OldArrPtrC As Long, OldpArrPtrC As Long
Dim LineAddBytes As Long
Dim PixelAddBytes As Long, mPtrC As Long
Const Blue As Long = 28
Const Green As Long = 150 '用long可以方便的避免VB的溢出错误
Const Red As Long = 77
If mHdc <> 0 And mBmpInfo.biBitCount = 32 Then
MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr '绑定模拟指针
MakePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC
mPtrC = GlobalAlloc(GPTR, mBmpInfo.biSizeImage)
CopyMemory ByVal mPtrC, ByVal mPtr, mBmpInfo.biSizeImage '复制真彩色图像的数据，其实就是一片连续的内存而已
If CreateDib(Width, Height, 8) = True Then '新建一个8位位图
pDataArr(0) = mPtr
pDataArrC(0) = mPtrC
LineAddBytes = mWidthBytes - mBmpInfo.biWidth '保证每个扫描行的宽度
For i = 1 To mBmpInfo.biHeight
For j = 1 To mBmpInfo.biWidth
DataArr(0) = (DataArrC(0) * Blue + DataArrC(1) * Green + DataArrC(2) * Red) \ 255 '灰度算法
pDataArrC(0) = pDataArrC(0) + 4
pDataArr(0) = pDataArr(0) + 1
Next
pDataArr(0) = pDataArr(0) + LineAddBytes '32位的位图不需要这个
Next
End If
GlobalFree mPtrC '释放分配的内存
FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
FreePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC '取消模拟指针
End If
ChangeToGreyMode = True
End Function

Public Function OutPut(ByVal OutDC As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal Width As Long, Optional ByVal Height As Long, Optional ByVal Srcx As Long = 0, Optional ByVal Srcy As Long = 0, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
If Width = 0 Then Width = mBmpInfo.biWidth
If Height = 0 Then Height = mBmpInfo.biHeight
OutPut = BitBlt(OutDC, x, y, Width, Height, mHdc, Srcx, Srcy, dwRop)
End Function


Public Sub Destroy()
If mHdc <> 0 Then
If mhDib <> 0 Then
SelectObject mHdc, mhOldDib
DeleteObject mhDib
End If
DeleteObject mHdc
mBmpInfo.biBitCount = 0
mBmpInfo.biWidth = 0
mBmpInfo.biHeight = 0
mBmpInfo.biSizeImage = 0
End If
mHdc = 0: mPtr = 0: mWidthBytes = 0
mhDib = 0: mhOldDib = 0:
End Sub


' 将Himetrics转变为 Pixels
Private Function ConvertHimetrix2Pixels(HiMetrix As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX
Else
ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelY
End If
End Function


'************************************************* ****************************************
'** 过 程 名 ： MakePoint
'** 输 入 ：
'** 功能描述 ： 绑定模拟数组
'** 开发日期 ： 2007-4-02
'** 作 者 ： laviewpbt
'** 修改日期 ：
'** 版 本 ： Version 1.2.1
'************************************************* ***************************************

Public Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long)
Dim Temp As Long, TempPtr As Long
CopyMemory Temp, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址
Temp = Temp + 12 '这个指针偏移12个字节后就是pvData指针
CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址
TempPtr = TempPtr + 12 '这个指针偏移12个字节后就是pvData指针
CopyMemory OldpArrPtr, ByVal TempPtr, 4 '保存旧地址
CopyMemory ByVal TempPtr, Temp, 4 '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指 针
CopyMemory OldArrPtr, ByVal Temp, 4 '保存旧地址
End Sub

'************************************************* ****************************************
'** 过 程 名 ： FreePoint
'** 输 入 ：
'** 功能描述 ： 取消绑定模拟数组
'** 开发日期 ： 2007-4-02
'** 作 者 ： laviewpbt
'** 修改日期 ：
'** 版 本 ： Version 1.2.1
'************************************************* ***************************************

Public Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal OldpArrPtr As Long)
Dim TempPtr As Long
CopyMemory TempPtr, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址
CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4 '恢复旧地址
CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址
CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4 '恢复旧地址
End Sub


'************************************************* ****************************************
'** 过 程 名 ： ChkFileWrite
'** 输 入 ： Filename - 文件路径，文件不存在，返回错误
'** 功能描述 ： 判断是否可以写入改文件
'** 开发日期 ： 2007-4-02
'** 作 者 ： laviewpbt
'** 修改日期 ：
'** 版 本 ： Version 1.2.1
'************************************************* ***************************************

Private Function ChkFileWrite(Filename As String) As Boolean
Dim FileNum As Long
FileNum = FreeFile
On Error Resume Next
Open Filename For Output As #FileNum
If Err.Number Then
Else
Close #FileNum
ChkFileWrite = True
End If
End Function

Public Function SavePictureToFile(Filename As String) As Boolean
Dim i As Long, j As Long
Dim FileNumber As Long, ColorTable() As RGBQUAD
Dim BmpInfoHeader As BITMAPFILEHEADER

If ChkFileWrite(Filename) = True And mHdc <> 0 Then '目标文件可写且有数据可写
BmpInfoHeader.bfType = &H4D42 'BMP文件的标识
If mBmpInfo.biBitCount = 8 Then '只有biBitCount等于1、4、8时才有调色板
BmpInfoHeader.bfOffBits = 54 + 4 * 256 '调色板的大小
ReDim ColorTable(0 To 255) As RGBQUAD
GetDIBColorTable mHdc, 0, 256, ColorTable(0)
ElseIf mBmpInfo.biBitCount = 32 Then
BmpInfoHeader.bfOffBits = 54
End If
BmpInfoHeader.bfSize = BmpInfoHeader.bfOffBits + mBmpInfo.biSizeImage '文件大小
FileNumber = FreeFile
Open Filename For Binary As #FileNumber
Put #FileNumber, , BmpInfoHeader 'BMP文件头
Put #FileNumber, , mBmpInfo '位图信息头
If mBmpInfo.biBitCount = 8 Then Put #FileNumber, , ColorTable '调色板
ReDim DibBytes(1 To mBmpInfo.biSizeImage) As Byte
CopyMemory DibBytes(1), ByVal mPtr, mBmpInfo.biSizeImage
Put #FileNumber, , DibBytes '位图数据
Close #FileNumber
SavePictureToFile = True
End If
End Function



Add a new form,and adding codes likes the followings.

Private Sub Form_Load()
Me.AutoRedraw = True
Dim Img As New Cimage
Img.LoadPictureFormFile "c:\2.bmp"
Img.ChangeToGreyMode
Img.OutPut Me.hdc
Me.Refresh
Img.SavePictureToFile "c:\3.bmp" '看看保存后的图像是不是8位的
Img.Destroy '记得一定要销毁哦
End Sub