因自己的程序中需对一个窗体区域频繁进行彩色转灰度处理为此专门写了个函数处理对象是一块经常变化的动态区域且是一系列绘图中的一部分速度要求较高算法上力求简单所以采用以下两步方案
基于DDB来写虽然转入DIB可不必面对各种色深会统一算法但转换过程会让速度上慢很多再者这只是针对屏幕位图的函数并无保存需要
考虑实际情况我只写了位三种色深下的算法其实两种位图是最快的了不管多大的图只需处理与次运算可是现在哪有人的屏幕还使用这两种显示模式呢？想想就没这个必要了
相比之下位时最快位时最慢心里有点不满意但好在速度都不慢差距也不超过%
灰度算法本来就不复杂但我还是做了简化正常处理时一般需对RGB做加权平均取个值来统一三基色但这需涉及浮点运算速度上不去效果却不见得有多好
我的方法很简单就是取三基色之一的值统一起来考虑人眼对绿色最敏感所以算法就成RGB转GGG了严格的说这不叫彩转灰叫绿转灰更合适RGB的排列G是在中间的想利用高速Long运算用B值最快的但已经够简化了再简下去自己都过意不去（用B值时位下速度还可快/）
这种算法当然有缺陷主要是对一些偏色图效果不好但好在这种情况在色彩丰富的界面中不存在
CG M WinXP SP下的测试情况
IDE环境下
X 的位图
位屏幕 毫秒
位屏幕 毫秒
N代码编译全部优化打开
X 的位图
位屏幕 毫秒
位屏幕 毫秒
注没有位环境所以也就没测了
Option Explicit
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 MemHdc
hdc As Long
Bmp As Long
obm As Long
End Type
Private Declare Function GetObj Lib gdi Alias GetObjectA (ByVal hObject As Long ByVal nCount As Long lpObject As Any) As Long
Private Declare Function SelectObject Lib gdi (ByVal hdc As Long ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib gdi (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib gdi (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib gdi (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 CreateCompatibleDC Lib gdi (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib gdi (ByVal hdc As Long ByVal nWidth As Long ByVal nHeight As Long) As Long
Private Declare Function GetBitmapBits Lib gdi (ByVal hBitmap As Long ByVal dwCount As Long lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib gdi (ByVal hBitmap As Long ByVal dwCount As Long lpBits As Any) As Long
Private Declare Function GetTickCount Lib kernel () As Long
Private Declare Sub CopyMemory Lib kernel Alias RtlMoveMemory (pDest As Any pSource As Any ByVal dwLength As Long)
平时常做图形处理自己的两个公用函数也就用上了
Private Function NewMyHdc(dHdc As Long w As Long h As Long Optional Bm As Long) As MemHdc
With NewMyHdc
hdc = CreateCompatibleDC(dHdc)
If Bm = Then
Bmp = CreateCompatibleBitmap(dHdc w h)
Else
Bmp = Bm
End If
obm = SelectObject(hdc Bmp)
End With
End Function
Private Function DelMyHdc(MyHdc As MemHdc Optional nobmp As Boolean) As MemHdc
With MyHdc
If hdc <> And obm <> Then SelectObject hdc obm
If nobmp = False And Bmp <> Then DeleteObject Bmp
If hdc <> Then DeleteDC hdc
End With
End Function
灰度处理主函数
Private Function GrayBmp(dHdc As Long x As Long y As Long w As Long h As Long) As Long
Dim tmpdc As MemHdc
Dim i As Long j As Long m As Long k As Byte l As Long
Dim Bm As BITMAP AllBytes As Long LineBytes As Long
Dim dBits() As Byte
Dim dBits() As Integer
Dim dBits() As Long
On Error GoTo last
With tmpdc
tmpdc = NewMyHdc(dHdc w h)
GetObj Bmp Len(Bm) Bm
If BmbmBitsPixel < Then GoTo last
BitBlt hdc w h dHdc x y vbSrcCopy
LineBytes = BmbmWidthBytes
AllBytes = LineBytes * h
Select Case BmbmBitsPixel
Case
ReDim dBits(AllBytes \ )
GetBitmapBits Bmp AllBytes dBits()
For i = To AllBytes \
dBits(i) = ((dBits(i) And &HFF&) \ &H) * &H
dBits(i) = (dBits(i) And &HFF) * &H用B值运算
Next
SetBitmapBits Bmp AllBytes dBits()
GrayBmp =
Case
ReDim dBits(AllBytes )
GetBitmapBits Bmp AllBytes dBits()
For j = To h
m = j * LineBytes
For i = m To m + w * Step
dBits(i) = dBits(i + )
dBits(i + ) = dBits(i)
Next
Next
SetBitmapBits Bmp AllBytes dBits()
GrayBmp =
Case
按格式运算
ReDim dBits(AllBytes \ )
GetBitmapBits Bmp AllBytes dBits()
For j = To h
m = j * LineBytes \
For i = m To m + w
l = dBits(i) And &HC&
l = l * + l + l \
CopyMemory dBits(i) l 这句没办法不用CopyMemory会溢出低效源于此
Next
Next
SetBitmapBits Bmp AllBytes dBits()
GrayBmp =
End Select
BitBlt dHdc x y w h hdc vbSrcCopy
End With
last:
DelMyHdc tmpdc
End Function
Private Sub Form_Load()
ScaleMode =
AutoRedraw = True
Picture = LoadPicture(f:\jpg)
CommandCaption = 测试
End Sub
测试用代码
Private Sub Form_Resize()
PaintPicture Picture ScaleWidth ScaleHeight
End Sub
Private Sub Command_Click()
Dim t As Long s As String s As String i As Long
t = GetTickCount
GrayBmp hdc ScaleWidth ScaleHeight
Refresh
MsgBox GetTickCount t & s
End Sub
