The fastest way to gray a picture .

[laviewpbt]

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


Option Explicit


Private Type BITMAPFILEHEADE R
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Type BITMAPINFOHEADE R
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 BITMAPINFOHEADE R
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_CREATEDIBSEC TION = &H2000 '如果指定了IMAGE_BIT MAP，就返回DIBSecti on的句柄，而不是位图 的句柄
Private Const STRETCH_ANDSCAN S = 1 '默认设置。剔除的线段与剩下的 线段进行AND运算。这个模式通 常应用于采用了白色背景的单色位 图
Private Const STRETCH_ORSCANS = 2 '剔除的线段被简单的清除。这个 模式通常用于彩色位 图
Private Const STRETCH_DELETES CANS = 3 '剔除的线段与剩下的线段进行O R运算。这个模式通常应用于采用 了白色背景的单色位 图
Private Const STRETCH_HALFTON E = 4 '目标位图上的像素块被设为源位 图上大致近似的块。这个模式要明 显慢于其他模式

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

Private Declare Function CreateDIBSectio n Lib "gdi32" (ByVal hdc As Long, lpBitsInfo As BITMAPINFOHEADE R, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibl eDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDIBColorTabl e Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long
Private Declare Function SetDIBColorTabl e 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 GetStretchBltMo de Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMo de 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 "RtlMoveMem ory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMem ory" (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 BITMAPINFOHEADE R '当前图像的文件信息


Private Sub Class_Terminate ()
Destroy
End Sub

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

Public Property Get Height() As Long
Height = mBmpInfo.biHeig ht
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 = CreateCompatibl eDC(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 = CreateDIBSectio n(mHdc, mBmpInfo, DIB_RGB_COLORS, mPtr, 0, 0) '创建DIB，mPtr就是指向 这个创建的DIBSECTION 的内存地址
If mhDib <> 0 Then
mhOldDib = SelectObject(mH dc, mhDib) '选入设备场景
If Bits = 8 Then '如果是8位，我们认为它是灰度 图像，建立起调色板
ReDim ColorTable(0 To 255) As RGBQUAD
For i = 0 To 255
ColorTable(i).R ed = i
ColorTable(i).G reen = i
ColorTable(i).B lue = i
Next
SetDIBColorTabl e mHdc, 0, 256, ColorTable(0) '设置调色板数据
End If
CreateDib = True
End If
End If
End Function


Public Function LoadPictureForm File(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(Fil ename)
If Not StdPic Is Nothing Then
Width = ConvertHimetrix 2Pixels(StdPic. Width, True) 'StdPicture宽度中的 单位是Himetr ics
Height = ConvertHimetrix 2Pixels(StdPic. Height, False)
If CreateDib(Width , Height, 32) = True Then '创建一个空白的Di b
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 ChangeToGreyMod e() 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.biBitC ount = 32 Then
MakePoint VarPtrArray(Dat aArr), VarPtrArray(pDa taArr), OldArrPtr, OldpArrPtr '绑定模拟指针
MakePoint VarPtrArray(Dat aArrC), VarPtrArray(pDa taArrC), OldArrPtrC, OldpArrPtrC
mPtrC = GlobalAlloc(GPT R, mBmpInfo.biSize Image)
CopyMemory ByVal mPtrC, ByVal mPtr, mBmpInfo.biSize Image '复制真彩色图像的数据，其实就 是一片连续的内存而 已
If CreateDib(Width , Height, 8) = True Then '新建一个8位位图
pDataArr(0) = mPtr
pDataArrC(0) = mPtrC
LineAddBytes = mWidthBytes - mBmpInfo.biWidt h '保证每个扫描行的宽 度
For i = 1 To mBmpInfo.biHeig ht
For j = 1 To mBmpInfo.biWidt h
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(Dat aArr), VarPtrArray(pDa taArr), OldArrPtr, OldpArrPtr
FreePoint VarPtrArray(Dat aArrC), VarPtrArray(pDa taArrC), OldArrPtrC, OldpArrPtrC '取消模拟指针
End If
ChangeToGreyMod e = 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 RasterOpConstan ts = vbSrcCopy) As Boolean
If Width = 0 Then Width = mBmpInfo.biWidt h
If Height = 0 Then Height = mBmpInfo.biHeig ht
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.biBitC ount = 0
mBmpInfo.biWidt h = 0
mBmpInfo.biHeig ht = 0
mBmpInfo.biSize Image = 0
End If
mHdc = 0: mPtr = 0: mWidthBytes = 0
mhDib = 0: mhOldDib = 0:
End Sub


' 将Himetric s转变为 Pixels
Private Function ConvertHimetrix 2Pixels(HiMetri x As Long, Horizontally As Boolean) As Long
If Horizontally Then
ConvertHimetrix 2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPer PixelX
Else
ConvertHimetrix 2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPer PixelY
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的S AFEARRAY结构的地址
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的SAFE ARRAY结构的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的S AFEARRAY结构的地址
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(Fi lename 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 SavePictureToFi le(Filename As String) As Boolean
Dim i As Long, j As Long
Dim FileNumber As Long, ColorTable() As RGBQUAD
Dim BmpInfoHeader As BITMAPFILEHEADE R

If ChkFileWrite(Fi lename) = True And mHdc <> 0 Then '目标文件可写且有数 据可写
BmpInfoHeader.b fType = &H4D42 'BMP文件的标识
If mBmpInfo.biBitC ount = 8 Then '只有biBitCount等于 1、4、8时才有调色 板
BmpInfoHeader.b fOffBits = 54 + 4 * 256 '调色板的大小
ReDim ColorTable(0 To 255) As RGBQUAD
GetDIBColorTabl e mHdc, 0, 256, ColorTable(0)
ElseIf mBmpInfo.biBitC ount = 32 Then
BmpInfoHeader.b fOffBits = 54
End If
BmpInfoHeader.b fSize = BmpInfoHeader.b fOffBits + mBmpInfo.biSize Image '文件大小
FileNumber = FreeFile
Open Filename For Binary As #FileNumber
Put #FileNumber, , BmpInfoHeader 'BMP文件头
Put #FileNumber, , mBmpInfo '位图信息头
If mBmpInfo.biBitC ount = 8 Then Put #FileNumber, , ColorTable '调色板
ReDim DibBytes(1 To mBmpInfo.biSize Image) As Byte
CopyMemory DibBytes(1), ByVal mPtr, mBmpInfo.biSize Image
Put #FileNumber, , DibBytes '位图数据
Close #FileNumber
SavePictureToFi le = 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.LoadPicture FormFile "c:\2.bmp"
Img.ChangeToGre yMode
Img.OutPut Me.hdc
Me.Refresh
Img.SavePicture ToFile "c:\3.bmp" '看看保存后的图像是 不是8位的
Img.Destroy '记得一定要销毁哦
End Sub